;;;;;-*- 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