;;;;;-*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;
;The following are used by simpleminded tests, not main system.
; LAM uses MEM-SLOT only to read memory description table out of sys-com region.
;no telling now...
;(defvar mem-slot)
(DEFCONST LAM-VMA-LEVEL-1-BYTE (BYTE 12. 13.))
(DEFCONST LAM-VMA-LEVEL-2-BYTE (BYTE 5 8))
(DEFMACRO ADD2L (ITEM LIST)
`(OR (NUMERIC-LIST-MEMQ ,ITEM ,LIST)
(SETQ ,LIST (CONS ,ITEM ,LIST))))
(COMMENT VIRTUAL MEMORY MAP MANIPULATION)
;READ OUT CONTENTS OF LEVEL 1 MAP
(DEFUN READ-LEVEL-1-MAP (ADR)
(WRITE-MD (DPB ADR LAM-VMA-LEVEL-1-BYTE 0)) ;ADDRESS VIA MD
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L1-MAP ;READ OUT MAP DATA
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(READ-MFO))
;WRITE INTO LEVEL 1 MAP
(DEFUN WRITE-LEVEL-1-MAP (ADR VAL)
(cond ((= 0 (ldb force-mi-reset-l (read-pmr)))
(ferror nil "unable to write level-1 map, force-mi-reset asserted")))
(WRITE-MD (DPB ADR LAM-VMA-LEVEL-1-BYTE 0)) ;ADDRESS VIA MD
(WRITE-SPY-REG VAL)
(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 LAM-FUNC-DEST-L1-MAP
LAM-IR-SLOW-DEST 1)
VAL)
;WRITE INTO LEVEL 2 MAP, control section
(DEFUN WRITE-LEVEL-2-MAP-CONTROL (ADR VAL)
(cond ((= 0 (ldb force-mi-reset-l (read-pmr)))
(ferror nil "unable to write level-2 map control, force-mi-reset asserted")))
(LET ((MAPADR (ADDRESS-LEVEL-2-MAP ADR)))
(WRITE-MD MAPADR)
(WRITE-SPY-REG VAL)
(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 LAM-FUNC-DEST-L2-MAP-CONTROL
LAM-IR-SLOW-DEST 1)
VAL))
;READ OUT CONTENTS OF LEVEL 2 MAP, control section
(DEFUN READ-LEVEL-2-MAP-CONTROL (ADR)
(WRITE-MD (ADDRESS-LEVEL-2-MAP ADR)) ;SET UP MD
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L2-MAP-CONTROL ;READ OUT MAP
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(READ-MFO))
;WRITE INTO LEVEL 2 MAP, physical-page section
(DEFUN WRITE-LEVEL-2-MAP-PHYSICAL-PAGE (ADR VAL)
(cond ((= 0 (ldb force-mi-reset-l (read-pmr)))
(ferror nil "unable to write level-2 map physical page, force-mi-reset asserted")))
(LET ((MAPADR (ADDRESS-LEVEL-2-MAP ADR)))
(WRITE-MD MAPADR)
(WRITE-SPY-REG VAL)
(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 LAM-FUNC-DEST-L2-MAP-PHYSICAL-PAGE
LAM-IR-SLOW-DEST 1)
VAL))
(DEFUN WRITE-LEVEL-2-MAP-PHYSICAL-PAGE-loop (ADR VAL)
(LET ((MAPADR (ADDRESS-LEVEL-2-MAP ADR)))
(WRITE-MD MAPADR)
(WRITE-SPY-REG VAL)
(do ()(())
(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 LAM-FUNC-DEST-L2-MAP-PHYSICAL-PAGE
LAM-IR-SLOW-DEST 1))
VAL))
(DEFUN READ-LEVEL-2-MAP-PHYSICAL-PAGE (ADR)
(WRITE-MD (ADDRESS-LEVEL-2-MAP ADR))
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L2-MAP-PHYSICAL-PAGE
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(READ-MFO))
;SUBROUTINE TO SET UP ADDRESS FOR LEVEL 2 MAP (USING LEVEL 1 MAP LOCATION 0)
;RETURNS VALUE TO GO INTO MD AS ADDRESS SOURCE
(DEFUN ADDRESS-LEVEL-2-MAP (ADR)
(WRITE-LEVEL-1-MAP 0 (LSH ADR -5)) ;HIGH 7 BITS OF ADDRESS TO LEVEL 1 MAP ENTRY 0
(DPB ADR LAM-VMA-LEVEL-2-BYTE 0)) ;LOW 5 BITS OF ADDRESS TO RETURN VALUE
;below arrays are used by bulk map reading functions.
(defconst lam-level-1-map-array (make-array 10000))
(defconst lam-level-2-map-control-array (make-array 10000))
(defconst lam-level-2-map-physical-page-array (make-array 10000))
(defun bulk-read-maps ()
(dotimes (a 4000) ;24 bit mode**
(aset (read-level-1-map a) lam-level-1-map-array a))
(dotimes (l2-block 200)
(write-level-1-map 0 l2-block)
(dotimes (offset 40)
(write-md (dpb offset lam-vma-level-2-byte 0))
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L2-MAP-PHYSICAL-PAGE
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(aset (READ-MFO) lam-level-2-map-physical-page-array (dpb l2-block 0507 offset))
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L2-MAP-CONTROL
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(aset (READ-MFO) lam-level-2-map-control-array (dpb l2-block 0507 offset)))))
(DEFUN UINST-MAIN-MEM-READ-LOOP ()
(MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
(send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) 0 -1)
(DISABLE-LAMBDA-AND-NU-MASTER)
(LOAD-STRAIGHT-MAP)
; (LOAD-CSM)
(lam-reset-cache)
(ULOAD ()
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-M-MEM-DEST 1)
LOC (LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU) ;let memory reply
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(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 2) ;save read data in 2.
(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)
'(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)
; 5400 in L2C-CONTENTS is map valid, write permit, and the packet size code
; for byte operations
;
; we map the virtual address to bytes pagewise:
; everyone points to page 0, but virtual page 0 goes to low byte
; 1 to byte 1, etc.
;
(DEFUN LOAD-byte-test-MAP (&OPTIONAL (NPAGES 10)
(PAGE-OFFSET 0)
(INDEX (SEND *PROC* :MEM-SLOT)))
(LET* ((quad-slot (configuration-index-to-quad-slot index))
(BASE-PHYSICAL-PAGE (ash quad-slot 14.))) ;+24. to nubus-address, -10. to page.
(DO ((L-2 0 (1+ L-2)))
(( L-2 NPAGES))
(WRITE-LEVEL-2-MAP-PHYSICAL-PAGE L-2 (dpb
l-2
(byte 2 22.)
(+ BASE-PHYSICAL-PAGE
PAGE-OFFSET)))
(WRITE-LEVEL-2-MAP-CONTROL L-2 5400)))
(DO ((L-1 0 (1+ L-1)))
(( L-1 40)) ;mapping only a quarter of it for now.
(WRITE-LEVEL-1-MAP L-1 L-1)))
(defun ubloop (&optional (data 04003002010))
(UINST-MAIN-MEM-BYTE-READ-LOOP data))
(DEFUN UINST-MAIN-MEM-BYTE-READ-LOOP (&OPTIONAL (DATA -1))
;READ DATA FROM MEMORY IN FOUR BYTES
;STORE IN M-MEM 2 - 5
(MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
(send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) 0 DATA)
(DISABLE-LAMBDA-AND-NU-MASTER)
(LOAD-byte-test-MAP)
(write-m-mem 6 400) ;page address increment
; (LOAD-CSM)
(lam-reset-cache)
(ULOAD ()
loc
(LAM-IR-OP LAM-OP-ALU ;ZERO M-MEM 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-M-MEM-DEST 1)
(LAM-IR-OP LAM-OP-ALU ;START A READ OF LOCATION 0, byte 0
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU ;save data in 2
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 2)
(lam-ir-op lam-op-alu ;increment m-1
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-add
lam-ir-m-src 1
lam-ir-a-src 6
lam-ir-m-mem-dest 1)
(LAM-IR-OP LAM-OP-ALU ;START A READ OF LOCATION 0, byte 1
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU ;save data in 3
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 3)
(lam-ir-op lam-op-alu ;increment m-1
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-add
lam-ir-m-src 1
lam-ir-a-src 6
lam-ir-m-mem-dest 1)
(LAM-IR-OP LAM-OP-ALU ;START A READ OF LOCATION 0, byte 2
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU ;save data in 4
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 4)
(lam-ir-op lam-op-alu ;increment m-1
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-add
lam-ir-m-src 1
lam-ir-a-src 6
lam-ir-m-mem-dest 1)
(LAM-IR-OP LAM-OP-ALU ;START A READ OF LOCATION 0, byte 3
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU ;save data in 5
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 5)
(LAM-IR-OP LAM-OP-JUMP ;jump to begining
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 ;error stop to catch random jumps
LAM-IR-JUMP-ADDR 0
LAM-IR-N 1
LAM-IR-JUMP-COND LAM-JUMP-COND-UNC))
(SETUP-MACHINE-TO-START-AT 100)
'(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)
(DEFUN UINST-MAIN-MEM-WRITE-LOOP (&OPTIONAL (DATA -1))
(DISABLE-LAMBDA-AND-NU-MASTER)
(LOAD-STRAIGHT-MAP)
; (LOAD-CSM)
(RESET-MI)
(lam-reset-cache)
(WRITE-MD DATA)
(MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
(send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) 0 105)
(ULOAD ()
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-M-MEM-DEST 1)
LOC (LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-WRITE
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU) ;let memory reply
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(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 2) ;save write data in 2.(make sure it twern't smashed)
(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)
'(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)
;(DECLARE (SPECIAL MEM-SLOT))
(DEFUN UINST-MAIN-MEM-COUNT-LOOP ()
(DISABLE-LAMBDA-AND-NU-MASTER)
(LOAD-STRAIGHT-MAP)
; (LOAD-CSM)
(RESET-MI)
(lam-reset-cache)
(MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
(send *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) 0 105)
(ULOAD ()
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-M-MEM-DEST 1)
LOC (LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC LAM-M-SRC-MD
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD-START-WRITE
LAM-IR-SLOW-DEST 1 ;***
;LAM-IR-M-MEM-DEST 2
LAM-IR-ALUF LAM-ALU-M+1
LAM-IR-CARRY 1)
(LAM-IR-OP LAM-OP-ALU)
DONE (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)
'(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)
(DEFUN UINST-CACHE-TEST-COUNT-LOOP (&optional (enable-cache 1) (MAIN-MEM-LOC 0)
(reflection-physical-page 0))
(DISABLE-LAMBDA-AND-NU-MASTER)
(LOAD-STRAIGHT-MAP 10 0 (DPB (IF ENABLE-CACHE 1 0)
(BYTE 1 14.)
(DPB 3 (BYTE 2 8) 0))
reflection-physical-page)
; (LOAD-CSM)
(RESET-MI)
(lam-reset-cache)
(MEMORY-SETUP (SEND *PROC* :MEM-SLOT))
(funcall *proc* :bus-slot-write (SEND *PROC* :MEM-SLOT) 0 105)
(write-m-mem 1 MAIN-MEM-LOC) ;MAIN MEMORY LOCATION TO POUND ON
(WRITE-M-MEM 3 0) ;INITIAL VALUE TO PUT THERE
(ULOAD ()
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-M-SRC 1
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA) ;LOAD VMA WITH MEM ADR OF INTEREST
(LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 3
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-MD-START-WRITE
LAM-IR-SLOW-DEST 1 ;***
LAM-IR-ALUF LAM-ALU-SETM) ;DO INITIAL WRITE OF "RIGHT THING"
(LAM-IR-OP LAM-OP-ALU)
LOC (LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU ;THROW IN A RANDOM WRITE
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-WRITE
LAM-IR-ALUF LAM-ALU-M+1)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-ALU ;NOW SIT IN LOOP READING IT
LAM-IR-M-SRC 1
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-VMA-START-READ
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU)
(LAM-IR-OP LAM-OP-JUMP
LAM-IR-M-SRC LAM-M-SRC-MD
LAM-IR-A-SRC 3
LAM-IR-JUMP-COND LAM-JUMP-COND-M=A
LAM-IR-N 1 ;LOOP IF SAME. THIS SHOULD TAKE CACHE HITS UNTIL
LAM-IR-JUMP-ADDR LOC) ; CACHE VERIFY CYCLE HAPPENS
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-M-SRC 3
LAM-IR-ALUF LAM-ALU-M+1
LAM-IR-CARRY 1
LAM-IR-M-MEM-DEST 3) ;INCREMENT COUNT
(LAM-IR-OP LAM-OP-JUMP
LAM-IR-M-SRC LAM-M-SRC-MD
LAM-IR-A-SRC 3
LAM-IR-JUMP-COND LAM-JUMP-COND-M=A
LAM-IR-N 1
LAM-IR-JUMP-ADDR LOC) ;IF DATA IS WHAT IT SHOULD BE, OK BACK TO LOOP.
ERROR
(LAM-IR-OP LAM-OP-JUMP
LAM-IR-JUMP-ADDR ERROR
LAM-IR-N 1
LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
LAM-IR-HALT 1)
(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)
(COND (ENABLE-CACHE
(CHANGE-PMR '(DEBUG-CACHE-PERMIT 1))))
(UINST-CACHE-TEST-COUNT-LOOP-1 (logxor (ash reflection-physical-page 8) MAIN-MEM-LOC)))
(DEFUN UINST-CACHE-TEST-COUNT-LOOP-1 (MAIN-MEM-LOC)
(format t "~%enable lambda")
(ENABLE-LAMBDA-AND-NU-MASTER)
(UINST-CACHE-TEST-LOOP-2 MAIN-MEM-LOC)
(SET-SINGLE-STEP-MODE)
(DISABLE-LAMBDA-AND-CLEAR-SINGLE-STEP)
(FORMAT T "~%PHYSICAL MEM: ~S, MACHINE ~S"
(PHYS-MEM-READ MAIN-MEM-LOC)
(READ-M-MEM 3))
)
(DEFUN UINST-CACHE-TEST-LOOP-2 (MAIN-MEM-LOC)
(DO ((val (phys-mem-read main-mem-loc)))
(())
(cond ((funcall standard-input ':listen) (return nil)))
(PHYS-MEM-WRITE MAIN-MEM-LOC (setq val (1+ val)))))
(DEFUN UINST-SUCCESSIVE-WRITE-TEST ()
(DISABLE-LAMBDA-AND-NU-MASTER)
(WRITE-M-MEM 4 123)
(WRITE-M-MEM 5 575757)
(ULOAD ()
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-M-MEM-DEST 1)
LOC (LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 4
LAM-IR-OB LAM-OB-ALU
LAM-IR-M-MEM-DEST 6
LAM-IR-ALUF LAM-ALU-SETM)
(LAM-IR-OP LAM-OP-ALU
LAM-IR-M-SRC 5
LAM-IR-OB LAM-OB-ALU
LAM-IR-M-MEM-DEST 10
LAM-IR-ALUF LAM-ALU-SETM)
DONE (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)
'(:SINGLE-UINST-MODE T)
)
;meta bits in the level 2 map control which can be tested by dispatch:
; oldspace bit -> l2-map-control bit 5, test enabled by bit 29 in dispatch instruction.
; on CADR, this was map 19, so there are places where it is called that.
; gc-write-test bit -> comes from gc logic., test enabled by bit 28 in dispatch instruction.
; on CADR, this was feed from map 18 so it was called that. It came
; directly from the level 2 map instead of from the GC logic there however.
;oldspace bit test loop.
; method: set up virtual page 0 (oldspace bit =1) to contain a -1 (oldspace bit =0).
; do a VMA-START-READ followed by a transporter style dispatch on MD.
(defun uinst-transporter-old-space-test-loop (&optional (p0-oldspace 1) (p3777-oldspace 0)
(pkt-code 0) (INDEX (SEND *PROC* :MEM-SLOT)))
(disable-lambda-and-nu-master)
(fast-zero-maps)
(lam-zero-a-mem)
(clear-25-bit-virtual-address-mode)
(write-level-1-map 0 0)
(write-level-1-map 3777 177)
(write-level-2-map-control 0 (dpb pkt-code (byte 2 11.)
(dpb p0-oldspace 501 1000))) ;read access +
(write-level-2-map-control 7777 (dpb p3777-oldspace 501 0000)) ;no access +
(LET* ((quad-slot (configuration-index-to-quad-slot index))
(BASE-PHYSICAL-PAGE (ash quad-slot 14.))) ;+24. to nubus-address, -10. to page.
(write-level-2-map-physical-page 0 base-physical-page))
(wipe-low-memory 400)
(let ((loop 100)
(error 10)
(m-main-mem-adr 1)
(main-mem-adr 0)
)
(phys-mem-write main-mem-adr -1)
(write-a-mem (logxor 4000 p3777-oldspace) loop) ;test should access this one
(write-a-mem (logxor 4000 p3777-oldspace 1) error) ;this one is lossage.
(write-m-mem m-main-mem-adr main-mem-adr)
(uload (loop error m-main-mem-adr)
0 (LAM-IR-OP LAM-OP-JUMP
LAM-IR-JUMP-ADDR 0
LAM-IR-N 1
LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
lam-ir-halt 1)
page-fault(lam-ir-op lam-op-jump
lam-ir-jump-addr page-fault
lam-ir-n 1
lam-ir-jump-cond lam-jump-cond-unc
lam-ir-halt 1)
error (lam-ir-op lam-op-jump
lam-ir-jump-addr error
lam-ir-n 1
lam-ir-jump-cond lam-jump-cond-unc)
loop (lam-ir-op lam-op-alu ;0 md so its visible when it loads.
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-md)
(lam-ir-op lam-op-alu
lam-ir-m-src m-main-mem-adr
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-func-dest lam-func-dest-vma-start-read)
(lam-ir-op lam-op-jump
lam-ir-jump-addr page-fault
lam-ir-n 1
lam-ir-jump-cond lam-jump-cond-page-fault)
(lam-ir-op lam-op-dispatch
lam-ir-m-src lam-m-src-md
lam-ir-disp-addr 4000
lam-ir-disp-bytl 1
lam-ir-disp-enable-oldspace-meta 1)
(lam-ir-op lam-op-alu)
(lam-ir-op lam-op-alu
lam-ir-halt 1)
))
(SETUP-MACHINE-TO-START-AT 100)
'(:SINGLE-UINST-MODE T :CSM-PRINTOUT T)
)
(DEFUN UI-AGAIN ()
(SETUP-MACHINE-TO-START-AT 100)
(SM-STEP-LOOP ':CSM-PRINTOUT T))
(DEFUN TEST-SHIFTER-LOGIC () "Shifter logic"
(TEST-MASKER)
(TEST-SHIFTER-FOR-STUCK-BITS)
(TEST-SHIFTER))
;;; Test Masker verifies that the masker works. This finds things like broken wires on
;;; the mask inputs to the output selectors
;;; The somewhat simple-minded algorithm is to make the masker select all M
;;; and make sure no bits from A get OR'ed in, then select all A and make sure
;;; no bits from M get OR'ed in.
;;; TEST-SHIFTER-FOR-STUCK-BITS tries to get all ones and all zeros through the
;;; shifter for all 32. rotations. it prints out the "bad ones" (bits which
;;; should be zero but are one) and "bad zeros" (vice-versa) for each rotation
;;;
;;; this should be easier to understand than the output of test-shifter for simple
;;; problems
;;; In test-shifter, the algorithm is to shift floating ones and
;;;zeros with all possible shifts.
;;;Record bits that failed at shifter input, at shifter output, between
;;;the two shifter stages, and also which shift counts fail.
(DEFUN TEST-SHIFTER ()
(FORMAT LAMBDA-DIAG-STREAM "~% SHIFTER TEST")
(WRITE-M-MEM 2 0) ;we will use it as a-mem,but it is
(LET ((RETURN-VALUE ;more consistant to write both
(*catch 'abort-test
(DO ((INPUT-ERRONEOUS-ZEROS NIL)
(MIDDLE-ERRONEOUS-ZEROS NIL)
(OUTPUT-ERRONEOUS-ZEROS NIL)
(INPUT-ERRONEOUS-ONES NIL)
(MIDDLE-ERRONEOUS-ONES NIL)
(OUTPUT-ERRONEOUS-ONES NIL)
(ERRONEOUS-SHIFT-COUNTS NIL)
(SUSPECT-BIT-LIST NIL)
(BITNO 0 (1+ BITNO))) ;THE FLOATING BIT
((= BITNO 32.)
(TERPRI)
(PRINT-BIT-LIST ERRONEOUS-SHIFT-COUNTS NIL "Shift counts with erroneous bits: ")
(PRINT-BIT-LIST INPUT-ERRONEOUS-ZEROS NIL "M bits with erroneous zeros: ")
(PRINT-BIT-LIST MIDDLE-ERRONEOUS-ZEROS NIL "SA bits with erroneous zeros: ")
(PRINT-BIT-LIST OUTPUT-ERRONEOUS-ZEROS NIL "R bits with erroneous zeros: ")
(PRINT-BIT-LIST INPUT-ERRONEOUS-ONES NIL "M bits with erroneous ones: ")
(PRINT-BIT-LIST MIDDLE-ERRONEOUS-ONES NIL "SA bits with erroneous ones: ")
(PRINT-BIT-LIST OUTPUT-ERRONEOUS-ONES NIL "R bits with erroneous ones: "))
(if (funcall tv:selected-window ':tyi-no-hang)
(*THROW 'ABORT-TEST "ABORTING TEST"))
(DO ((BACKGROUND 37777777777 0)) ;FIRST FLOATING ZEROS, THEN FLOATING ONES
(())
(if (funcall tv:selected-window ':tyi-no-hang)
(*THROW 'ABORT-TEST "ABORTING TEST"))
(WRITE-m-mem 1 (LOGXOR BACKGROUND (ASH 1 BITNO))) ;SHIFTER INPUT
(DO ((MROT 0 (1+ MROT))
(BAD)
(GOOD (LOGXOR BACKGROUND (ASH 1 BITNO)) ;EXPECTED OUTPUT
(ROT32 GOOD 1)))
((= MROT 32.))
(if (funcall tv:selected-window ':tyi-no-hang)
(*THROW 'ABORT-TEST "ABORTING TEST"))
(setq bad (byte-ldb 2 1 (- 40 mrot) 32.))
;
;do an ldb from 2@A and 1@M
;set it to "bad" for convenience
;if it turns out to be wrong.
;byte is 32. wide.
;so no bits of A should matter
;if things are working right
;MROT = 32. - BITS-OVER
;BITS-OVER = 32. - MROT
(COND ((NOT (= BAD GOOD)) ;HA! AN ERROR, STASH STUFF AWAY
(COND (DIAG-TRACE
(FORMAT T "~&mrot: ~D. , testing bit# ~D. , Good: ~O, Bad: ~O,~
Reread: ~O"
MROT
BITNO
GOOD
BAD
(READ-MFO))) )
(ADD2L MROT ERRONEOUS-SHIFT-COUNTS)
(DO ((J 0 (1+ J)) ;BITS OF OUTPUT
(GOOD GOOD (ASH GOOD -1))
(BAD BAD (ASH BAD -1)))
((= J 32.))
(if (funcall tv:selected-window ':tyi-no-hang)
(*THROW 'ABORT-TEST "ABORTING TEST"))
(OR (= (LOGAND 1 GOOD) (LOGAND 1 BAD))
(COND ((ZEROP (LOGAND 1 GOOD)) ;AN ERRONEOUS ONE
(ADD2L J OUTPUT-ERRONEOUS-ONES)
(ADD2L (LOGAND (- J MROT) 37) INPUT-ERRONEOUS-ONES)
(ADD2L (LOGAND (- J (LOGAND MROT -4)) 37) MIDDLE-ERRONEOUS-ONES))
(T
(ADD2L J OUTPUT-ERRONEOUS-ZEROS)
(ADD2L (LOGAND (- J MROT) 37) INPUT-ERRONEOUS-ZEROS)
(ADD2L (LOGAND (- J (LOGAND MROT -4)) 37) MIDDLE-ERRONEOUS-ZEROS)
)))))))
(AND (ZEROP BACKGROUND) (RETURN NIL)))))))
(AND (STRINGP RETURN-VALUE) (FORMAT LAMBDA-DIAG-STREAM ".......ABORTING TEST"))
RETURN-VALUE))
(DEFUN TEST-SHIFTER-FOR-STUCK-BITS ()
(format lambda-diag-stream "~% testing shifter for stuck bits")
(WRITE-M-MEM 1 0)
(WRITE-M-MEM 2 -1)
(LET ((RETURN-VALUE
(*CATCH 'ABORT-TEST
(DO ((MROT 0 (1+ MROT))
(ERRORP-0 NIL)
(ERRORP-1 NIL)
(BAD-0 0)
(BAD-1 37777777777))
((= MROT 32.))
(IF (FUNCALL TV:SELECTED-WINDOW ':TYI-NO-HANG)
(*THROW 'ABORT-TEST "ABORTING-TEST"))
(IF (NOT (= (SETQ BAD-0 (BYTE-LDB 1 1 (- 40 MROT) 32.)) 0))
(SETQ ERRORP-0 T))
(IF (NOT (= (SETQ BAD-1 (BYTE-LDB 1 2 (- 40 MROT) 32.)) 37777777777))
(SETQ ERRORP-1 T))
(IF (OR ERRORP-0 ERRORP-1)
(FORMAT T "~%ERROR FOR MROT = ~D. " MROT))
(COND (ERRORP-0
(FORMAT T "BAD ONES ")
(PRINT-BITS BAD-0)))
(COND (ERRORP-1
(FORMAT T "BAD ZEROES ")
(PRINT-BITS (LOGXOR 37777777777 BAD-1))))))))
(AND (STRINGP RETURN-VALUE) (FORMAT LAMBDA-DIAG-STREAM ".......ABORTING TEST"))
RETURN-VALUE))
(DEFUN ROT32 (NUM AMT)
(LOGAND 37777777777
(COND ((< AMT 30) (+ (ASH NUM AMT) (LDB (+ (LSH (- 40 AMT) 6) AMT) NUM)))
(T (DPB (LDB (- 40 AMT) NUM)
(+ (LSH AMT 6) (- 40 AMT))
(ASH NUM (- AMT 40)))))))
(DEFUN TEST-MASKER () "Masker"
(format lambda-diag-stream "~% MASKER TEST")
(LET ((SUSPECT-BIT-LIST NIL))
(WRITE-A-MEM 1 37777777777)
(WRITE-M-MEM 2 0)
(LAM-EXECUTE (READ)
LAM-IR-OP LAM-OP-BYTE
LAM-IR-A-SRC 1
LAM-IR-M-SRC 2
LAM-IR-BYTL-1 37
LAM-IR-MROT 0
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-SELECTIVE-DEPOSIT)
(PRINT-BIT-LIST (WRONG-BITS-LIST 0 (READ-MFO) 32.) NIL
"Erroneous A bits coming through masker:")
(LET ((RH 0) (LH 0))
(WRITE-A-MEM 1 0)
(WRITE-M-MEM 2 37777777777)
(LAM-EXECUTE (READ)
LAM-IR-OP LAM-OP-BYTE ;Select A in the right half
LAM-IR-A-SRC 1
LAM-IR-M-SRC 2
LAM-IR-BYTL-1 17
LAM-IR-MROT 20
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-SELECTIVE-DEPOSIT)
(SETQ RH (READ-MFO))
(LAM-EXECUTE (READ)
LAM-IR-OP LAM-OP-BYTE ;Select A in the left half
LAM-IR-A-SRC 1
LAM-IR-M-SRC 2
LAM-IR-BYTL-1 17
LAM-IR-MROT 0
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-SELECTIVE-DEPOSIT)
(SETQ LH (READ-MFO))
(PRINT-BIT-LIST (WRONG-BITS-LIST 0 (DPB (LDB 2020 LH) 2020 RH) 32.) NIL
"Erroneous M bits coming through masker:"))
(write-a-mem 1 200)
(write-m-mem 2 (lsh 377 10))
(lam-execute (read)
lam-ir-op lam-op-byte
lam-ir-a-src 1
lam-ir-m-src 2
lam-ir-bytl-1 7
lam-ir-mrot 10
lam-ir-byte-func lam-byte-func-selective-deposit)
(let ((ans (read-mfo)))
(cond ((= ans 200)
(format t "~%selective deposit did deposit byte operation instead. check byte.s.rotate"))
((not (= ans (+ (lsh 377 10) 200)))
(format t "selective deposit got wrong result"))))))
(DEFCONST C-MASK-28 36000000000)
(DEFCONST C-MASK-25 37600000000) ;USEFUL FOR ADDITION TO POINTERS
(DEFCONST C-MASK-24 37700000000)
(DEFCONST C-MASK-20 37774000000)
(DEFCONST C-MASK-16 37777600000)
(DEFCONST C-MASK-12 37777770000)
(DEFCONST C-MASK-11 37777774000) ;USEFUL FOR ADDITION TO PDL POINTER OR INDEX
(DEFCONST C-MASK-8 37777777400)
(DEFCONST C-MASK-4 37777777760)
(DEFCONST C-MASK-JADR 30000037777) ;JUMP ADDRESS ON LOW IMOD 16 wide,14 over
(DEFCONST C-MASK-BYTE-POS 37777777700) ;BYTE POSITION ON LOW IMOD 6 wide, 0 over
(DEFCONST C-MASK-BYTE-LEN 37777770077) ;BYTE LENGTH ON LOW IMOD 6 wide, 6 over
(DEFCONST C-MASK-M-SOURCE 37777777600) ;M-SOURCE ON HIGH IMOD 7 wide, 0 over
(DEFCONST C-MASK-A-SOURCE 37776000177) ;A-SOURCE ON HIGH IMOD 12 wide, 7 over
;test new stuff in masker proms, 6/1/84
(defun test-masked-add ()
(write-m-mem 1 -1)
(write-m-mem 2 0)
(masked-add-trial c-mask-28 1 0 1 2)
(masked-add-trial c-mask-25 1 0 0 0) ;independant of Q.control
(masked-add-trial c-mask-25 1 0 0 3) ;independant of Q.control
(masked-add-trial c-mask-24 0 1 1 2)
(masked-add-trial c-mask-20 0 0 1 2)
(masked-add-trial c-mask-16 1 1 1 1)
(masked-add-trial c-mask-12 1 0 1 1)
(masked-add-trial c-mask-11 1 1 0 0) ;independant of Q.control
(masked-add-trial c-mask-11 1 1 0 3) ;independant of Q.control
(masked-add-trial c-mask-8 0 1 1 1)
(masked-add-trial c-mask-4 0 0 1 1)
(masked-add-trial c-mask-jadr 1 1 1 2)
(masked-add-trial c-mask-byte-pos 0 0 1 3)
(masked-add-trial c-mask-byte-len 0 1 1 3)
(masked-add-trial c-mask-m-source 1 0 1 3)
(masked-add-trial c-mask-a-source 1 1 1 3)
)
(defun masked-add-trial (mask ir.alu.control.5 ir.alu.ob.con.2 uinst.29 q.control)
(lam-execute (read)
lam-ir-op lam-op-alu
lam-ir-ob-control-bussed 1
lam-ir-alu-control-5 ir.alu.control.5
lam-ir-ob-control-2 ir.alu.ob.con.2
lam-ir-uinst-29 uinst.29
lam-ir-q q.control
lam-ir-a-src 1
lam-ir-m-src 2
lam-ir-real-aluf lam-alu-setm)
(cond ((not (= mask (read-mfo)))
(format t "~%Got ~s instead of ~s, alu.c.5=~S, ob.con.2=~s, u29=~s, qc=~s"
(read-mfo) mask ir.alu.control.5 ir.alu.ob.con.2 uinst.29 q.control))))
;**** stuff below here not checked over yet
(COMMENT
(DEFUN READ-LEVEL-1-MAP-AND-CHECK-PARITY (ADR)
(PROG NIL
(WRITE-MD (DPB ADR LAM-VMA-LEVEL-1-BYTE 0)) ;ADDRESS VIA MD
(LAM-EXECUTE LAM-IR-M-SRC LAM-M-SRC-MAP ;READ OUT MAP DATA
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(RETURN (LOGLDB-FROM-FIXNUM LAM-MAP-LEVEL-1-BYTE (READ-OBUS))
(PROGN (NOOP-CLOCK)
(COND ((ZEROP (LDB 1501 (SPY-READ SPY-FLAG-1)))
(FORMAT T "~%BAD LEVEL-1-MAP PARITY, ADR ~S" ADR)
T))))))
(DEFUN SCAN-LEVEL-1-MAP-FOR-BAD-PARITY (&AUX (ADR-AND 7777) (ADR-IOR 0)
(DATA-AND 37) (DATA-IOR 0)
DAT LOSEP (LOSES 0))
(DOTIMES (ADR 10000)
(MULTIPLE-VALUE (DAT LOSEP)
(READ-LEVEL-1-MAP-AND-CHECK-PARITY ADR))
(COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR)
ADR-IOR (LOGIOR ADR-IOR ADR)
DATA-AND (LOGAND DATA-AND DAT)
DATA-IOR (LOGIOR DATA-IOR DAT)
LOSES (1+ LOSES)))))
(COND ((NOT (ZEROP LOSES))
(FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O"
LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR))))
(DEFUN READ-LEVEL-2-MAP-CONTROL-AND-CHECK-PARITY (ADR)
(WRITE-MD (ADDRESS-LEVEL-2-MAP ADR)) ;SET UP MD
(LAM-EXECUTE (READ)
LAM-IR-M-SRC LAM-M-SRC-L2-MAP-CONTROL ;READ OUT MAP
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU)
(LET ((MFO (READ-MFO)))
(VALUES MFO
(PROGN (ADVANCE-TO-NEXT-UINST-CLOCK)
(COND ((NOT (ZEROP (LDB 2101 (READ-PARITY))))
(FORMAT T "~%BAD LEVEL-2-MAP-CONTROL PARITY, ADR ~S" ADR)
T))))))
(DEFUN SCAN-LEVEL-2-MAP-CONTROL-FOR-BAD-PARITY (&AUX (ADR-AND 7777) (ADR-IOR 0)
(DATA-AND 77777777) (DATA-IOR 0)
DAT LOSEP (LOSES 0))
(DOTIMES (ADR 10000)
(MULTIPLE-VALUE (DAT LOSEP)
(READ-LEVEL-2-MAP-CONTROL-AND-CHECK-PARITY ADR))
(COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR)
ADR-IOR (LOGIOR ADR-IOR ADR)
DATA-AND (LOGAND DATA-AND DAT)
DATA-IOR (LOGIOR DATA-IOR DAT)
LOSES (1+ LOSES)))))
(COND ((NOT (ZEROP LOSES))
(FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O"
LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR))))
;find level 2 map entries which are non-zero but do not have access bit set.
(DEFUN SCAN-LEVEL-2-MAP-FOR-GARBAGE (&OPTIONAL RUNNING-PRINTOUT
&AUX (ADR-AND 1777) (ADR-IOR 0)
(DATA-AND 77777777) (DATA-IOR 0)
DAT LOSEP (LOSES 0))
(DOTIMES (ADR 2000)
(SETQ DAT (READ-LEVEL-2-MAP-AND-CHECK-PARITY ADR))
(SETQ LOSEP (AND (NOT (ZEROP DAT))
(ZEROP (LOGAND DAT 1_23.))))
(COND (LOSEP (SETQ ADR-AND (LOGAND ADR-AND ADR)
ADR-IOR (LOGIOR ADR-IOR ADR)
DATA-AND (LOGAND DATA-AND DAT)
DATA-IOR (LOGIOR DATA-IOR DAT)
LOSES (1+ LOSES))
(IF RUNNING-PRINTOUT (FORMAT T "~%adr ~s, data ~s" ADR DAT)))))
(COND ((NOT (ZEROP LOSES))
(FORMAT T "~%~D loses: ADRAND=~O, ADRIOR=~O, DATAAND=~O, DATAIOR=~O"
LOSES ADR-AND ADR-IOR DATA-AND DATA-IOR))))
) ;END COMMENT
;map in multibus memory
;there are 200 pages worth of multibus memory currently.
;but there are now 400 pages worth of new winning nubus memory!!!
; 1400 in L2C-CONTENTS is map valid and write permit
(DEFUN LOAD-STRAIGHT-MAP (&OPTIONAL (NPAGES 10) (PAGE-OFFSET 0) (L2C-CONTENTS 1400)
(REFLECTION-PHYSICAL-PAGE 0) (INDEX (SEND *PROC* :MEM-SLOT)))
(LET* ((quad-slot (configuration-index-to-quad-slot index))
(BASE-PHYSICAL-PAGE (ash quad-slot 14.))) ;+24. to nubus-address, -10. to page.
(DO ((L-2 0 (1+ L-2)))
(( L-2 NPAGES))
(WRITE-LEVEL-2-MAP-PHYSICAL-PAGE L-2 (+ BASE-PHYSICAL-PAGE
(logxor reflection-physical-page L-2)
PAGE-OFFSET))
(WRITE-LEVEL-2-MAP-CONTROL L-2 L2C-CONTENTS)))
(DO ((L-1 0 (1+ L-1)))
(( L-1 40)) ;mapping only a quarter of it for now.
(WRITE-LEVEL-1-MAP L-1 L-1)))
(DEFUN LOAD-STRAIGHT-CRAM-ADR-MAP (&OPTIONAL (NPAGES 20))
(DOTIMES (C NPAGES)
(WRITE-CAM-WITH-GOOD-PARITY C C)))
(defun check-straight-cram-adr-map (&optional (first-page 0) (npages 2000))
(dotimes (c npages)
(let ((map (read-cram-adr-map (+ first-page c))))
(cond ((not (= (logand map 3777) (+ first-page c)))
(ferror nil "Cram map not straight, adr ~s data ~s" (+ first-page c) map))))))
;;THE ULOAD BASED VERSION IS NOW OBSOLETE: NOW SHOULD USE THE UTEST VERSION WHICH
;;IS SDU COMPATIBLE. (ALSO, THAT VERSION COMPUTES GOOD PARITY, WRITES THE ENTIRE
;;MAP,THEN READS BACK AND CHECKS)
(DEFUN FAST-LOAD-STRAIGHT-CRAM-ADR-MAP ()
(fld-straight-cam))
;(old-fast-load-straight-cram-adr-map) was used for 3 and less.
(DEFUN old-FAST-LOAD-STRAIGHT-CRAM-ADR-MAP ()
(FORMAT T "~%;...loading cram adr map the old way without readback or parity")
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
(WRITE-M-MEM 1 7777) ;location to clobber
(WRITE-M-MEM 2 1) ;last locn to clobber. Also used as constant!
(WRITE-M-MEM 3 0) ;constant for DPBing into
(write-m-mem 4 10.)
(ULOAD ()
0
; ((m-5) m-4) ;copy constant
; ((m-7) setz) ;initialize parity
; pl ((oa-reg-low) dpb m-5 (byte-field 5 0) (a-constant 0)) ;modify ldb
; ((m-6) ldb) ;pick bit
; ((m-7) xor) ;xor it in
; (jump-less-than-xct-next pl)
; ((m-5) sub m-5 (a-constant 1))
; ((m-8) dpb m-7 (byte-field 1 10.) a-1) ;insert parity in.
(LAM-IR-OP LAM-OP-BYTE ;((oa-reg-low) dpb m-1 oal-cram-page-number a-3)
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
LAM-IR-M-SRC 1
LAM-IR-BYTL-1 11.
LAM-IR-MROT 18.
LAM-IR-A-SRC 3
LAM-IR-FUNC-DEST LAM-FUNC-DEST-IMOD-LOW)
(LAM-IR-OP LAM-OP-JUMP ;(call-xct-next 17)
LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
LAM-IR-JUMP-ADDR 17
LAM-IR-P 1
LAM-IR-N 0)
(LAM-IR-POPJ-AFTER-NEXT 1 ;(popj-after-next (cram-adr-map) setm m-1)
LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-M-SRC 1
LAM-IR-FUNC-DEST LAM-FUNC-DEST-CRAM-MAP
LAM-IR-SLOW-DEST 1)
(LAM-IR-OP LAM-OP-JUMP ;3
LAM-IR-JUMP-COND LAM-JUMP-COND-M>A
LAM-IR-M-SRC 1
LAM-IR-A-SRC 2
LAM-IR-JUMP-ADDR 0
LAM-IR-N 0)
(LAM-IR-OP LAM-OP-ALU ;4
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SUB
LAM-IR-M-SRC 1
LAM-IR-A-SRC 2
LAM-IR-M-MEM-DEST 1)
(lam-ir-halt 1) ) ;5
(SETUP-MACHINE-TO-START-AT 0)
(cond ((access-path-lmi-serial-protocol *proc*)
(funcall *proc* ':string-out "0R")
(funcall *proc* ':read-32)
(funcall *proc* ':string-out "2h")
(funcall *proc* ':read-32))
(t
(ENABLE-LAMBDA)
(PROCESS-SLEEP 2)
(DISABLE-LAMBDA-AND-NU-MASTER)
(COND ((NOT (= (READ-PC) 6))
(FERROR NIL "FAST-LOAD-STRAIGHT-CRAM-ADR-MAP DID NOT HALT IN THE RIGHT PLACE(6)")))))
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
)
(defun pack-memory-descriptor (list-of-memories &optional (shift 0))
(cond ((null list-of-memories) 0)
(t (+ (ash (car list-of-memories) shift)
(pack-memory-descriptor (cdr list-of-memories) (+ shift 4))))))
;FAST-LOAD-STRAIGHT-CRAM-ADR-MAP and INITIALIZE-MEMORIES. Which memories is
; non-zero 4 bits groups in 4@M
(DEFUN INITIALIZE-LAMBDA-AND-MEMORIES ()
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
(cond ((access-path-lmi-serial-protocol *proc*)
(send *proc* ':string-out "200M")
(funcall *proc* ':read-32))
(T
(write-m-mem 4 (pack-memory-descriptor (get-list-of-memory-slots)))))
(WRITE-M-MEM 1 7777) ;location to clobber
(WRITE-M-MEM 2 1) ;last locn to clobber. Also used as constant!
(WRITE-M-MEM 3 0) ;constant for DPBing into
;4 CONTAINS MEMORIES TO INITIALIZE, 4 BITS EA
(write-m-mem 5 0) ;5 is memory to initialize this time
(write-m-mem 6 0) ;6 is temporary
(write-m-mem 7 (ash 17 18.)) ;7 is constant for putting in map
(write-m-mem 10 0) ;constant 0
(write-m-mem 11 37777777777) ;constant -1
(write-m-mem 12 400) ;constant
(write-m-mem 13 37767) ;constant
(write-m-mem 14 771) ;constant
(write-m-mem 15 (ash 4 8))
(write-m-mem 16 (ash 8 8))
(write-m-mem 17 8)
(ULOAD ()
0
(lam-ir-halt 1) ;random halt
done (lam-ir-halt 1) ;normal halt
illop (lam-ir-halt 1) ;bad page fault
;program starts at 3
beg (LAM-IR-OP LAM-OP-BYTE ;((oa-reg-low) dpb m-1 oal-cram-page-number a-3)
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
LAM-IR-M-SRC 1
LAM-IR-BYTL-1 11.
LAM-IR-MROT 18.
LAM-IR-A-SRC 3
LAM-IR-FUNC-DEST LAM-FUNC-DEST-IMOD-LOW)
(LAM-IR-OP LAM-OP-JUMP ;(call-xct-next 17)
LAM-IR-JUMP-COND LAM-JUMP-COND-UNC
LAM-IR-JUMP-ADDR 17
LAM-IR-P 1
LAM-IR-N 0)
(LAM-IR-POPJ-AFTER-NEXT 1 ;(popj-after-next (cram-adr-map) setm m-1)
LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-M-SRC 1
LAM-IR-FUNC-DEST LAM-FUNC-DEST-CRAM-MAP
LAM-IR-SLOW-DEST 1)
(LAM-IR-OP LAM-OP-JUMP
LAM-IR-JUMP-COND LAM-JUMP-COND-M>A
LAM-IR-M-SRC 1
LAM-IR-A-SRC 2
LAM-IR-JUMP-ADDR BEG
LAM-IR-N 0)
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SUB
LAM-IR-M-SRC 1
LAM-IR-A-SRC 2
LAM-IR-M-MEM-DEST 1)
;now initialize memories.
ml ;(jump-equal m-4 a-zero done)
(lam-ir-op lam-op-jump
lam-ir-m-src 4
lam-ir-a-src 10
lam-ir-jump-addr done
lam-ir-jump-cond lam-jump-cond-m=a
lam-ir-n 1)
;((m-5) ldb (byte-field 4 0) m-4 a-zero)
(lam-ir-op lam-op-byte
lam-ir-a-src 10
lam-ir-m-src 4
lam-ir-bytl-1 3
lam-ir-mrot 0
lam-ir-byte-func lam-byte-func-ldb
lam-ir-m-mem-dest 5)
;((m-4) ldb (byte-field 28. 4) m-4 a-zero)
(lam-ir-op lam-op-byte
lam-ir-a-src 10
lam-ir-m-src 4
lam-ir-bytl-1 27.
lam-ir-mrot 34
lam-ir-byte-func lam-byte-func-ldb
lam-ir-m-mem-dest 4)
;(jump-equal m-5 a-zero ml) m-5 has mem to init
(lam-ir-op lam-op-jump
lam-ir-m-src 5
lam-ir-a-src 10
lam-ir-jump-addr ml
lam-ir-jump-cond lam-jump-cond-m=a
lam-ir-n 1)
;set up page zero to zero of desired slot.
;((md) setz)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-md
lam-ir-slow-dest 1)
;((l2-map-control) dpb m-ones (byte-field 2 8) a-zero)
(lam-ir-op lam-op-byte
lam-ir-a-src 10
lam-ir-m-src 11
lam-ir-bytl-1 1
lam-ir-mrot 8
lam-ir-byte-func lam-byte-func-dpb
lam-ir-func-dest lam-func-dest-l2-map-control
lam-ir-slow-dest 1)
;((l2-map-physical-page m-6)
; dpb m-5 (byte-field 4 14.)
; (a-constant (byte-mask (byte-field 4 18.)))) a-7
(lam-ir-op lam-op-byte
lam-ir-a-src 7
lam-ir-m-src 5
lam-ir-bytl-1 3
lam-ir-mrot 14.
lam-ir-byte-func lam-byte-func-dpb
lam-ir-func-dest lam-func-dest-l2-map-physical-page
lam-ir-m-mem-dest 6
lam-ir-slow-dest 1)
;set up page one to memory-control-reg-adr #16RFFDFE5 ;read/write. 8 bits.
;not going to bother with byte operation, tho.
;((md) add md a-400) ;a-12
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-add
lam-ir-m-src lam-m-src-md
lam-ir-a-src 12
lam-ir-func-dest lam-func-dest-md
lam-ir-slow-dest 1)
;((l2-map-control) dpb m-ones (byte-field 2 8) a-zero)
(lam-ir-op lam-op-byte
lam-ir-a-src 10
lam-ir-m-src 11
lam-ir-bytl-1 1
lam-ir-mrot 8
lam-ir-byte-func lam-byte-func-dpb
lam-ir-func-dest lam-func-dest-l2-map-control
lam-ir-slow-dest 1)
;((l2-map-physical-page) selective-deposit
; m-6 (byte-field 8 14.)
; (a-constant 37767))
;;;(ash control-reg-adr -10) stored in a-13
(lam-ir-op lam-op-byte
lam-ir-a-src 13
lam-ir-m-src 6
lam-ir-bytl-1 7
lam-ir-mrot 14.
lam-ir-byte-func lam-byte-func-selective-deposit
lam-ir-func-dest lam-func-dest-l2-map-physical-page
lam-ir-slow-dest 1)
;((vma) (a-constant 771))
;;;pg 1,word bits within page, stored in 14
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-m-src 14
lam-ir-func-dest lam-func-dest-vma
lam-ir-slow-dest 1)
;((md-start-write) (ash 4 8)) , stored in 15
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-m-src 15
lam-ir-func-dest lam-func-dest-md-start-write
lam-ir-slow-dest 1)
;(call-if-page-fault illop)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-page-fault
lam-ir-jump-addr illop
lam-ir-p 1
lam-ir-n 1)
;((m-6) (a-constant 8)) , stored in 17
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-m-src 17
lam-ir-m-mem-dest 6)
;((md) setz)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-md
lam-ir-slow-dest 1)
zr-loop ;((vma-start-write) a-zero)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-vma-start-write
lam-ir-slow-dest 1)
;(call-if-page-fault illop)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-page-fault
lam-ir-jump-addr illop
lam-ir-p 1
lam-ir-n 1)
;(jump-greater-or-equal-xct-next m-6 a-zero zr-loop)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-m>=a
lam-ir-m-src 6
lam-ir-a-src 10
lam-ir-jump-addr zr-loop
lam-ir-n 0)
;((m-6) sub m-6 (a-constant 1)) , a-2
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-m-src 6
lam-ir-a-src 2
lam-ir-aluf lam-alu-sub
lam-ir-m-mem-dest 6)
;((vma) (a-constant 771)) ;pg 1, word bits within page
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-m-src 14
lam-ir-func-dest lam-func-dest-vma
lam-ir-slow-dest 1)
;((md-start-write) (ash 8 8)) ,stored in 16
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setm
lam-ir-m-src 16
lam-ir-func-dest lam-func-dest-md-start-write
lam-ir-slow-dest 1)
;(call-if-page-fault illop)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-page-fault
lam-ir-jump-addr illop
lam-ir-p 1
lam-ir-n 1)
;((vma-start-write) a-zero)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-vma-start-write
lam-ir-slow-dest 1)
;(call-if-page-fault illop)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-page-fault
lam-ir-jump-addr illop
lam-ir-p 1
lam-ir-n 1)
;(jump ml)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-unc
lam-ir-jump-addr ml
lam-ir-n 1)
)
(SETUP-MACHINE-TO-START-AT 3)
(cond ((access-path-lmi-serial-protocol *proc*)
(funcall *proc* ':string-out "1R")
(funcall *proc* ':read-32)
(funcall *proc* ':string-out "2h")
(funcall *proc* ':read-32))
(t
(ENABLE-LAMBDA)
(PROCESS-SLEEP 2)
(DISABLE-LAMBDA-AND-NU-MASTER)))
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
)
(defun fast-load-straight-map-loop nil
(do ((pkt-code 0)
(enable-cache 0)
(reflection-physical-page 0))
(())
(FAST-LOAD-STRAIGHT-MAP
':L2C-CONTENTS (DPB PKT-CODE (BYTE 2 11.)
(DPB (IF ENABLE-CACHE 1 0)
(BYTE 1 14.)
(DPB 3 (BYTE 2 8) 0)))
':REFLECTION-PHYSICAL-PAGE REFLECTION-PHYSICAL-PAGE)))
;L2C bits: bit-num mask desc
; 7-0 377 "meta" bits
; bits 1,0 volitility code this page. Input to GC-WRITE-TEST logic.
; bit 5 is oldspace bit, used by transporter dispatch.
; 8 400 write-permit
; 9 1000 map.valid
; 10 2000 map.valid.if.force
; 12-11 14000 map.packet.size.code
; 0- word ops
; 1- byte ops (which byte in L2-map-physical-page)
; 2- blocks, 2 long
; 3- blocks, 16. long
; 13 20000 unused
; 14 40000 map.cache.permit
; 15 100000 map.lock.nubus
(DEFUN FAST-LOAD-STRAIGHT-MAP (&KEY &OPTIONAL
(N-L2-PAGES 4096.)
(L2-PAGE-OFFSET 0)
(L2C-CONTENTS 1400)
(UNUSED-L1-ENTRIES 177)
(REFLECTION-PHYSICAL-PAGE 0)
(INDEX (SEND *PROC* :MEM-SLOT)))
(LET* ((quad-slot (configuration-index-to-quad-slot index))
(BASE-PHYSICAL-PAGE (ash quad-slot 14.))) ;+24. to nubus-address, -10. to page.
(FAST-LOAD-STRAIGHT-MAP-LEVEL-1 UNUSED-L1-ENTRIES)
(FAST-LOAD-STRAIGHT-MAP-LEVEL-2 0 N-L2-PAGES L2C-CONTENTS
(+ BASE-PHYSICAL-PAGE L2-PAGE-OFFSET)
REFLECTION-PHYSICAL-PAGE)))
(DEFUN FAST-LOAD-STRAIGHT-MAP-LEVEL-1 (&OPTIONAL (UNUSED-ENTRY-DATA 177))
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
(SET-25-BIT-VIRTUAL-ADDRESS-MODE)
(LET ((M-A 5) (M-B 6) (M-C 7) (M-D 10) (M-E 11)
(SAVED-C-MEM (LAM-MULTIPLE-READ-C-MEM 0 20))
(SAVED-M-MEM (LAM-MULTIPLE-READ-M-MEM 5 5)))
(WRITE-M-MEM M-A 0) ;map data
(WRITE-M-MEM M-B (ASH 1 13.)) ;map address increment
(WRITE-M-MEM M-C (// 4096. 32.)) ;end test first phase. POINT AT 4096 LOCS IN L2 MAP
;ONLY 2048. LOCS IN LEVEL 1 MAP ACTIVE IN 24 BIT MODE.
(WRITE-M-MEM M-D 4096.) ;end test second phase
(WRITE-M-MEM M-E UNUSED-ENTRY-DATA) ;store this in second phase.
(write-md 0)
(uload (M-A M-B M-C M-D M-E)
0
loc ;((level-1-map) M-a)
(LAM-IR-M-SRC M-A
LAM-IR-ALUF LAM-ALU-SETM
LAM-IR-OB LAM-OB-ALU
LAM-IR-FUNC-DEST LAM-FUNC-DEST-L1-MAP
LAM-IR-SLOW-DEST 1)
(LAM-IR-OB LAM-OB-ALU ;((M-A) M+1 M-A)
LAM-IR-M-MEM-DEST M-A
LAM-IR-M-SRC M-A
LAM-IR-ALUF LAM-ALU-M+1)
(LAM-IR-OP LAM-OP-JUMP ;(JUMP-LESS-THAN-XCT-NEXT M-A A-C LOC)
LAM-IR-M-SRC M-A
LAM-IR-A-SRC M-C
LAM-IR-JUMP-COND LAM-JUMP-COND-M= LOCATION-COUNTER STOP) (NREVERSE C-DATA))))
; RESTORE AFTER MULTIPLE SAVE.
(DEFUN LAM-MULTIPLE-WRITE-C-MEM (STARTING-LOCATION DATA-LIST) ;WILL WRITE UNTIL
(DO ((LOCATION STARTING-LOCATION (1+ LOCATION)) ;NO MORE DATA.
(C-DATA DATA-LIST (CDR C-DATA)))
((NULL C-DATA) DATA-LIST)
(LAM-WRITE-C-MEM LOCATION (CAR C-DATA))))
(DEFUN LAM-MULTIPLE-READ-M-MEM (LOCATION NUMBER-OF-WORDS)
(DO ((LOCATION-COUNTER LOCATION (1+ LOCATION-COUNTER))
(M-DATA NIL (CONS (LAM-READ-M-MEM LOCATION-COUNTER) M-DATA))
(STOP (+ LOCATION NUMBER-OF-WORDS)))
((>= LOCATION-COUNTER STOP) (NREVERSE M-DATA))))
; RESTORE AFTER MULTIPLE SAVE.
(DEFUN LAM-MULTIPLE-WRITE-M-MEM (STARTING-LOCATION DATA-LIST) ;WILL WRITE UNTIL
(DO ((LOCATION STARTING-LOCATION (1+ LOCATION)) ;NO MORE DATA.
(M-DATA DATA-LIST (CDR M-DATA)))
((NULL M-DATA) DATA-LIST)
(LAM-WRITE-M-MEM LOCATION (CAR M-DATA))))
;;; Hacks to permit LAM-RUN-MTEST only to load the microcode once.
(DEFVAR MTEST-UCODE (MAKE-ARRAY 7000. ':TYPE 'ART-8B ':LEADER-LIST '(0)))
(DEFVAR UCODE-COUNTER 0)
(DEFVAR UCODE-TRUENAME)
(DEFUN MTEST-UCODE-STREAM (OP &OPTIONAL ARG1 &REST REST)
(SELECTQ OP
(:RESET
(WITH-OPEN-FILE (STREAM "LM1:lambda-ucode;memd.lam-uload" ':direction ':input)
(setq ucode-truename (funcall stream ':truename))
(setq ucode-counter 0)
(store-array-leader 0 mtest-ucode 0)
(do
((value (funcall stream ':tyi) (funcall stream ':tyi)))
((not value))
(array-push-extend mtest-ucode value))))
(:tyi
(if (< ucode-counter (array-active-length mtest-ucode))
(aref mtest-ucode (1- (setq ucode-counter (1+ ucode-counter))))
nil))
(:untyi
(setq ucode-counter (1- ucode-counter)))
(:truename ucode-truename)
(:close
t)
(:WHICH-OPERATIONS '(:reset :tyi :untyi :close :truename))
(OTHERWISE
(STREAM-DEFAULT-HANDLER (FUNCTION mtest-ucode-stream)
OP ARG1 REST))))
(putprop 'mtest-ucode-stream t 'si:io-stream-p)
(defconst ucode-dummy nil) ; (funcall 'mtest-ucode-stream ':reset)
(DEFUN LAM-RUN-MTEST (&KEY &OPTIONAL
ALREADY-LOADED RANGE
;(MAP-OFFSET 0)
(AUTO-P T)
(RESET-P T)
(ENABLE-CACHE NIL)
(PKT-CODE 0)
(TESTS '(0 1 2 3 4 5 6 7))
(repeat-infinitely nil) ;sit in single test ..
(ENABLE-PARITY-STOP NIL)
(FILE NIL) ;DEFAULT IS "LM1:LAMBDA-UCODE;MEMD.LAM-ULOAD"
(REFLECTION-PHYSICAL-PAGE 0) ;17 IS GOOD FOR TESTING SLOW CACHE HIT.
(STAT-COUNTER-OPTION 'COUNT-CSM-STAT)
(INDEX (SEND *PROC* :MEM-SLOT))
&AUX PC SYMBOLIC-PC CHAR
ERRORS OTHER-ERRORS ADRAND ADRIOR DATAAND DATAIOR QUAD-SLOT)
;If RESET-P is T, we will eventually filter down to SETUP-NUBUS-CONFIGURATION, which
; will set up mem-slot and initialize the memories.
(setq quad-slot (configuration-index-to-quad-slot index))
(COND ((NULL ALREADY-LOADED)
(LAM-ZERO-ENTIRE-MACHINE RESET-P) ;THIS INCLUDES SETTING UP THE CAM
(COND ((NULL FILE)
(SETQ FILE "LM1: LAMBDA-UCODE; MEMD.LAM-ULOAD")
(SETQ UCODE-COUNTER 0)
(LAM-UCODE-LOADER NIL FILE NIL 'mtest-ucode-stream T)
(LAM-RECORD-SYMBOL-TABLE 'mtest-ucode-stream))
(T
(LAM-UCODE-LOADER NIL FILE NIL NIL T)))
(SETQ LAM-FILE-SYMBOLS-LOADED-FROM FILE) ;OLDER, LOSING HACK
(FORMAT T "~%memory diagnostic microcode loaded"))
((and (boundp 'lam-file-symbols-loaded-from)
(string-equal lam-file-symbols-loaded-from FILE)))
(t nil)) ;nothing needed here since symbols are selected below
(format t "~%Using memory board in configuration index ~s, quad-slot ~s"
index quad-slot)
(LET ((SAVED-C-MEM (LAM-MULTIPLE-READ-C-MEM 0 30)))
(FLD-STRAIGHT-MAP ;FAST-LOAD-STRAIGHT-MAP
':L2C-CONTENTS (DPB PKT-CODE (BYTE 2 11.)
(DPB (IF ENABLE-CACHE 1 0)
(BYTE 1 14.)
(DPB 3 (BYTE 2 8) 0)))
':REFLECTION-PHYSICAL-PAGE REFLECTION-PHYSICAL-PAGE
':INDEX INDEX)
(LAM-MULTIPLE-WRITE-C-MEM 0 SAVED-C-MEM))
(lam-reset-cache)
(COND (ENABLE-CACHE (enable-cache)))
(FORMAT T "~%straight virtual-to-physical memory map loaded, cache ~:[disabled~;enabled~]"
ENABLE-CACHE)
;(COND ((ZEROP MAP-OFFSET) (FAST-LOAD-STRAIGHT-MAP))
; (T (LOAD-STRAIGHT-MAP MAP-OFFSET)))
(lam-select-symbol-table 'mtest-ucode-stream) ;** reset to memd symbols
(FORMAT T "~%just selected symbol table")
(COND ((NULL RANGE)
(LAM-SYMBOLIC-DEPOSIT-REGISTER 'A-MAIN-MEMORY-START 0)
(LAM-SYMBOLIC-DEPOSIT-REGISTER 'A-MAIN-MEMORY-SIZE (SEND *PROC* :MAIN-MEMORY-SIZE)))
(T (LAM-SYMBOLIC-DEPOSIT-REGISTER 'A-MAIN-MEMORY-START (CAR RANGE))
(LAM-SYMBOLIC-DEPOSIT-REGISTER 'A-MAIN-MEMORY-SIZE (CADR RANGE))))
(LET () ;((LAM-MODE-REG LAM-MOD-REG)) ;SAME SPEED, DISABLE PROM, ENABLE
;(IF RESET-P (LAM-RESET-MACH)) ; ERROR STOPS.
(IF ENABLE-PARITY-STOP (ENABLE-PARITY))
(setq lam-passive-save-valid t ;to cause the saved pc to get restored
LAM-FULL-SAVE-VALID T)
(DOLIST (TEST TESTS)
(format t "~%Memory Test ~o: ~[zeroes in all locations~;~
ones in all locations~;~
floating zero pattern in all locations; shift data and repeat~;~
floating one pattern in all locations; shift data and repeat~;~
floating zero pattern; shift data and increment address~;~
floating one pattern; shift data and increment address~;~
rotated address as data for all possible rotations~;~
rotated and complemented address as data for all possible rotations~;~]"
test test)
top (SETQ ERRORS 0 OTHER-ERRORS 0
ADRAND 77777777 ADRIOR 0 DATAAND 37777777777 DATAIOR 0)
(selectq stat-counter-option
(count-csm-stat (set-main-stat-counter-to-count-csm-stat)))
(SETQ LAM-UPDATE-DISPLAY-FLAG T)
(LAM-SYMBOLIC-DEPOSIT-REGISTER 'M-TEST TEST)
(LAM-REGISTER-DEPOSIT RASA (LAM-SYMBOLIC-CMEM-ADR 'MEMORY-DATA-TEST))
CONT (LAM-REGISTER-DEPOSIT RAGO 0)
L (COND ((SETQ CHAR (send terminal-io :tyi-no-hang))
(GO X1))
((ZEROP (LAM-REGISTER-EXAMINE RAGO)) (GO X)))
(PROCESS-SLEEP 30. "MTest Wait") ;WHY WAIT AS LONG?
(GO L)
X1 (COND ((= CHAR #/ )
(FORMAT T "~%Aborting test ~D" TEST)
(LAM-REGISTER-DEPOSIT RASTOP 0)
(GO E)))
X (LAM-REGISTER-DEPOSIT RASTOP 0)
(COND ((NOT (OR (= (SETQ PC (LAM-REGISTER-EXAMINE RAPC))
(1+ (LAM-SYMBOLIC-CMEM-ADR 'MEMORY-TEST-OK)))
(>= ERRORS 100.))) ;give up after 100. errors.
(SETQ SYMBOLIC-PC (LAM-FIND-CLOSEST-SYM (+ RACMO PC)))
(IF (NULL AUTO-P)
(FORMAT T "~%Test ~D halted at ~S (= ~O) " TEST SYMBOLIC-PC PC)
(SETQ ERRORS (1+ ERRORS))
(LET* ((CORRECT-DATA
(LAM-SYMBOLIC-EXAMINE-REGISTER
'A-CURRENT-MEMORY-DATA))
(WRONG-BITS (LOGXOR LAM-SAVED-MD CORRECT-DATA)))
(IF (NOT (MEMBER SYMBOLIC-PC '((ERROR-WRONG-DATA 1))))
(PROGN (SETQ OTHER-ERRORS (1+ OTHER-ERRORS))
(FORMAT T "~%unexpected stop ~s!!" SYMBOLIC-PC)
(LAM))
(SETQ ADRAND (LOGAND ADRAND LAM-SAVED-VMA)
ADRIOR (LOGIOR ADRIOR LAM-SAVED-VMA)
DATAAND (LOGAND WRONG-BITS DATAAND)
DATAIOR (LOGIOR WRONG-BITS DATAIOR))
(FORMAT T "~%VMA ~s, MD ~s, MD should be ~s,~
while the Main Memory location contains ~s~
~%halted at ~S, wrong bits:"
LAM-SAVED-VMA LAM-SAVED-MD CORRECT-DATA
(bus-READ (+ (ash QUAD-SLOT 24.)
(ash (LOGXOR (ASH REFLECTION-PHYSICAL-PAGE 8)
LAM-SAVED-VMA)
2)))
symbolic-pc)
(PRINT-BITS WRONG-BITS)))
(GO CONT)))
((NOT (ZEROP ERRORS))
(FORMAT T "~%Test ~D, ~D errors, ADRAND ~S,
ADRIOR ~S, DATAAND ~S, DATAIOR ~S, other errors ~D"
TEST ERRORS ADRAND ADRIOR DATAAND DATAIOR
OTHER-ERRORS)
(FORMAT T "~%DATAIOR bits ")
(PRINT-BITS DATAIOR))
(T (FORMAT T " - Test ~D OK, stat ~S!" TEST (READ-STAT-COUNTER))
))
E (if repeat-infinitely (go top)))))
(DEFUN LAM-SYMBOLIC-CMEM-ADR (SYM)
(LET ((VAL (LAM-LOOKUP-NAME SYM)))
(COND ((OR (< VAL RACMO)
(NOT (< VAL RACME)))
(FERROR NIL "The symbol ~s is not a C-MEM symbol" SYM)))
(- VAL RACMO)))
;;; Initializer for when machine has just been powered up. -*-LISP-*-
(DECLARE (SPECIAL LAM-PDL-BUFFER-INDEX-CHANGED-FLAG
LAM-MICRO-STACK-SAVED-FLAG
LAM-SAVED-DISPATCH-CONSTANT
LAM-PASSIVE-SAVE-VALID
LAM-FULL-SAVE-VALID))
;still needs to clear cache ,CSM
(DEFUN LAM-ZERO-ENTIRE-MACHINE (&OPTIONAL (RESET-P T) &KEY (EVEN-CONTROL-MEMORY T))
(LET ((DEFAULT-PARITY-ENABLE-LIST NIL) ;NO PARITY HERE .. THE POINT IS TO WRITE
(CHECK-PARITY NIL)) ;GOOD PARITY IN THE FIRST PLACE
(SETQ LAM-FULL-SAVE-VALID NIL
LAM-PASSIVE-SAVE-VALID NIL
LAM-SAVED-MICRO-STACK-PTR NIL
LAM-SAVED-PDL-BUFFER-INDEX NIL)
(IF RESET-P (POWER-UP-INITIALIZE))
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER)
(FAST-LOAD-STRAIGHT-CRAM-ADR-MAP) ;LOADS STRAIGHT CRAM-ADR MAP WITH GOOD PARITY
;AND THEN READ BACK AND CHECK,
;EXECPT IF THE CON PROM INDICATES THAT
;THE BOARDS ARE TOO OLD
;
(CLEAR-MICRO-STACK) ;PUSHES 0 256 TIMES, CLEARING ENTIRE MEMORY
(FAST-ZERO-MAPS) ;Works now.
(FAST-CLEAR-MID)
(LAM-ZERO-A-MEM) ;Clear A memory
(IF EVEN-CONTROL-MEMORY
(LAM-ZERO-C-MEM)) ;Clear control memory
(FAST-CLEAR-M-AND-PDL) ; clears whole 4K of M and PDL
))
(defun fast-clear-m-and-pdl (&optional dont-start)
(assure-noop-cleared-and-no-carryover)
(write-m-mem 0 0)
(write-a-mem 0 0)
(write-m-mem 1 1)
(write-m-mem 2 4000)
(write-m-mem 3 0)
(write-pp 3) ; first push will cause location 4 to be written
(change-dp-mode '(pdl.address.high 0)) ; start clearing m mem
(uload ()
0
;((c-pdl-buffer-pointer-push) setz)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-c-pdl-buffer-pointer-push)
;(jump-not-equal pdl-buffer-pointer (a-constant 0) 0)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-m-neq-a
lam-ir-m-src lam-m-src-pdl-buffer-pointer
lam-ir-a-src 3
lam-ir-jump-addr 0
lam-ir-n 1)
;now clear pdl itself
;((dp-mode) (a-constant 1))
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-seta
lam-ir-a-src 1
lam-ir-func-dest lam-func-dest-dp-mode)
;((pdl-buffer-pointer) setz)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-pdl-buffer-pointer)
;clear the first location
;((c-pdl-buffer-pointer) a-zero)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-c-pdl-buffer-pointer)
second-part
;((c-pdl-buffer-pointer-push) a-zero)
(lam-ir-op lam-op-alu
lam-ir-ob lam-ob-alu
lam-ir-aluf lam-alu-setz
lam-ir-func-dest lam-func-dest-c-pdl-buffer-pointer-push)
;(jump-not-equal pdl-buffer-pointer (a-constant 0) second-part)
(lam-ir-op lam-op-jump
lam-ir-jump-cond lam-jump-cond-m-neq-a
lam-ir-m-src lam-m-src-pdl-buffer-pointer
lam-ir-a-src 3
lam-ir-jump-addr second-part
lam-ir-n 1)
;(halt)
(lam-ir-halt 1)
;(setz)
(lam-ir-op lam-op-alu)
)
(cond ((not dont-start)
(SETUP-MACHINE-TO-START-AT 0)
(cond ((access-path-lmi-serial-protocol *proc*)
(funcall *proc* ':string-out "0R")
(funcall *proc* ':read-32)
(funcall *proc* ':string-out "2h")
(funcall *proc* ':read-32))
(t
(ENABLE-LAMBDA)
(PROCESS-SLEEP 2)
(DISABLE-LAMBDA-AND-NU-MASTER)))
(ASSURE-NOOP-CLEARED-AND-NO-CARRYOVER))))
(DEFUN LAM-ZERO-A-MEM ()
(WRITE-M-MEM 1 4)
(WRITE-M-MEM 2 7777)
(WRITE-M-MEM 3 0)
(ULOAD ()
0 (LAM-IR-OP LAM-OP-BYTE
LAM-IR-BYTE-FUNC LAM-BYTE-FUNC-DPB
LAM-IR-M-SRC 1
LAM-IR-BYTL-1 11.
LAM-IR-MROT 14.
LAM-IR-A-SRC 3
LAM-IR-FUNC-DEST LAM-FUNC-DEST-IMOD-LOW)
(LAM-IR-OP LAM-OP-ALU
LAM-IR-OB LAM-OB-ALU
LAM-IR-ALUF LAM-ALU-SETZ
LAM-IR-A-MEM-DEST-FLAG 1
LAM-IR-A-MEM-DEST 0)
(LAM-IR-OP LAM-OP-JUMP
LAM-IR-JUMP-COND LAM-JUMP-COND-M