;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*- ;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc. ;;; (DECLARE (SPECIAL LAM-ACCESS-PATH LAM-UPDATE-DISPLAY-FLAG LAM-REG-ADR-PHYS-MEM-OFFSET )) (DEFVAR LAM-LOW-LEVEL-FLAG NIL) (DEFVAR LAM-PASSIVE-SAVE-VALID NIL) (DEFVAR LAM-FULL-SAVE-VALID NIL) (DEFVAR LAM-RUNNING NIL) ;SM-STEP, UINST-STEP, OR T (DEFVAR LAM-RUNNING-CHECK-PARITY NIL) ;CHECK-PARITY, BEFORE IT WAS MAYBE TURNNED OFF. (DEFCONST LAM-NUMBER-OF-SAVED-OPCS 1000) (DEFVAR LAM-SAVED-OPCS (MAKE-ARRAY (- RAOPCE RAOPCO))) (DEFVAR LAM-SAVED-OPCS-VALID NIL) (DEFVAR LAM-SAVED-HPTR 0) ;clocking an instruction clobbers the hptr (DEFVAR LAM-MICRO-STACK (MAKE-ARRAY 256.)) (DEFVAR LAM-NOOP-FLAG NIL) ;holds state of hardware no-op flag if ; full state save valid. (DEFVAR LAM-SAVED-PDL-BUFFER-INDEX NIL) ;nil not changed (DEFVAR LAM-SAVED-MICRO-STACK-PTR NIL) ;nil not saved. also implies active microstack ; saved. (DEFVAR LAM-SAVED-LEVEL-1-MAP-LOC-0 NIL) ;nil not saved (DEFVAR LAM-SAVED-IR 0) (DEFVAR LAM-SAVED-PC 0) (DEFVAR LAM-SAVED-MFOBUS 0) (DEFVAR LAM-VMA-CHANGED-FLAG NIL) (DEFVAR LAM-SAVED-VMA 0) (DEFVAR LAM-SAVED-MD 0) (DEFVAR LAM-SAVED-MAP-AND-FAULT-STATUS 0) (defvar lam-saved-macro-ir 0) (DEFVAR LAM-SAVED-PARITY-ENABLES 0) ;PARITY ENABLES PER BOARD (DEFVAR LAM-SAVED-PARITY-VECTOR 0) ;ACTUAL PARITY ERROR BITS (defvar lam-saved-explorer-md-and-vma-enable-modes 0) ;SAVE THE PDL-BUFFER-INDEX INTO LAM-SAVED-PDL-BUFFER-INDEX (DEFUN LAM-SAVE-PDL-BUFFER-INDEX () (or lam-saved-pdl-buffer-index (SETQ LAM-SAVED-PDL-BUFFER-INDEX (send *proc* :READ-PI)))) (defun lam-stop-mach () (send *proc* :stop-mach)) (defun lam-start-mach () (send *proc* :start-mach)) (DEFUN LAM-SET-CHECK-PARITY (ARG) (COND ((EQ ARG 0) (SETQ LAM-RUNNING-CHECK-PARITY NIL)) ((EQ ARG 1) (SETQ LAM-RUNNING-CHECK-PARITY T)))) (defun lam-single-step () (send *proc* :single-step)) ;ARG IF POSITIVE IS A COUNT OTHERWISE IT IS THE REGISTER ADDRESS OF PC TO STOP AT. ;LATER ON THIS SHOULD USE THE STAT COUNTER? (defun lam-step-mach (arg) (selectq current-processor-type (:lambda (lam-step-mach-lambda arg)) (:explorer (lam-step-mach-explorer arg)) (t (ferror nil "foo")))) (defun lam-step-mach-lambda (arg) (cond ((>= arg 0) (dotimes (n (max arg 1)) (lam-single-step))) (t (setq arg (- arg racmo)) ;stop pc (do ((first t nil)) ((or (send terminal-io :tyi-no-hang) (and (not first) (= (lam-read-pc) arg)))) (lam-single-step))))) (defun lam-step-mach-explorer (arg) (cond ((>= arg 0) (dotimes (n (1- (max arg 1))) (lam-single-step))) (t (ferror nil "foo")))) (defun lam-halted () (send *proc* :halted-p)) (DEFF LAM-HALTED-BY-PROG-OR-ERROR 'lam-halted) ;FOR NOW. ; save and restore the state of the machine ;SAVE THINGS WHICH CAN BE SAVED WITHOUT MODIFYING THE STATE OF THE MACHINE (DEFUN LAM-PASSIVE-SAVE () (send *proc* :passive-save)) (DEFUN LAM-DUMMY-PASSIVE-SAVE () (COND ((NOT LAM-PASSIVE-SAVE-VALID) (SETQ LAM-SAVED-PDL-BUFFER-INDEX NIL) ;FIRST OF ALL, CLEAR FLAGS (setq LAM-SAVED-MICRO-STACK-PTR NIL) ; WHICH MARK AUXILIARY PORTIONS ; OF THE MACHINE NEED RESTORATION (setq LAM-SAVED-LEVEL-1-MAP-LOC-0 NIL) (setq LAM-VMA-CHANGED-FLAG NIL) ;MRD ALMOST ALWAYS CHANGED, ALWAYS RESTORE IT (setq LAM-SAVED-OPCS-VALID NIL) (SETQ LAM-SAVED-HPTR 0) (setq LAM-SAVED-PC 0) (setq LAM-SAVED-IR 0) (setq LAM-SAVED-mfOBUS 0) (setq LAM-NOOP-FLAG NIL) (SETQ LAM-PASSIVE-SAVE-VALID T)))) ;FULL SAVE (DEFUN LAM-FULL-SAVE (&optional resave) (when resave (setq lam-full-save-valid nil) (setq lam-passive-save-valid nil)) (send *proc* :full-save)) ;call this to "simulate" having read state from machine. ;ie this gets things into the state where you can then munge state, then do full restore ; and expect to win. (defun lam-dummy-full-save () (send *proc* :dummy-full-save)) (DEFUN LAM-ENTER () (COND ((EQ LAM-LOW-LEVEL-FLAG 'VERY) (LAM-STOP-MACH) (LAM-PASSIVE-SAVE)) ((NULL LAM-FULL-SAVE-VALID) (LAM-FULL-SAVE)))) ;Put everything back in the real machine, but dont completely forget ; about it. (DEFUN LAM-REPLACE-STATE NIL (ferror nil "foo")) ;RESTORE THAT (DEFUN LAM-FULL-RESTORE () (send *proc* :full-restore)) (defun lam-save-opcs (&optional count) (send *proc* :save-opcs count)) (DEFUN LAM-SAVE-MEM-STATUS () (send *proc* :save-mem-status)) (DEFUN LAM-DUMMY-SAVE-MEM-STATUS () (SETQ LAM-SAVED-VMA 0 LAM-SAVED-MD 0)) (defun lam-restore-mem-status () (send *proc* :restore-mem-status)) ; register address interface (DEFUN LAM-PRINT-REG-ADR-CONTENTS (ADR) (PROG (RANGE DATA PCPART) (SETQ RANGE (LAM-FIND-REG-ADR-RANGE ADR)) (SETQ DATA (COND ((EQ RANGE 'RAIDR) (AREF LAM-RAID-REG (- ADR RARDRO))) ;RAIDR RANGE IS IN 10 ((LAM-REGISTER-EXAMINE ADR)))) (SETQ LAM-LAST-VALUE-TYPED DATA) (COND ((OR (MEMQ RANGE '(C)) (= ADR RAIR) (= ADR RASIR)) (LAM-TYPE-OUT DATA LAM-UINST-DESC T NIL)) ((and data (MEMQ RANGE '(U OPC))) (SETQ PCPART (\ DATA (selectq (send *proc* :proc-type) (:lambda (- RACME RACMO)) (:explorer 16384.) ))) (LAM-PRINT-ADDRESS (+ PCPART RACMO)) ;PCP PART SYMBOLICALLY (COND ((NOT (= DATA PCPART)) ;RESIDUE, IF ANY, NUMERICALLY (PRINC '| + |) (PRIN1 (- DATA PCPART)))) (PRINC '/ )) ((EQ RANGE 'RAIDR) (LAM-PRINT-ADDRESS DATA) (PRINC '/ )) (T (PRIN1-THEN-SPACE DATA))) (PRINC '/ / ))) ;RETURNS: NIL IF NONE FOUND CLOSER THAN 20 TO DESIRED REG ADR ; SYMBOL IF EXACT MATCH FOUND ; (LIST SYMBOL DIFFERENCE) IF ONE FOUND CLOSER THAN 20 (DEFUN LAM-FIND-REG-ADR-RANGE (REG-ADR) (COND ((>= REG-ADR 0) 'VIRTUAL) ((<= REG-ADR LAM-REG-ADR-PHYS-MEM-TOP) 'PHYSICAL) ((< REG-ADR RACME) 'C) ((< REG-ADR RADME) 'D) ((< REG-ADR RAPBE) 'P) ((< REG-ADR RAM1E) '/1) ((< REG-ADR RAM2E-CONTROL) '/2C) ((< REG-ADR RAM2E-PHYSICAL-PAGE) '/2P) ((< REG-ADR RAAME) 'A) ((< REG-ADR RAUSE) 'U) ((< REG-ADR RAMIDE) 'MID) ((< REG-ADR RACAME) 'CAM) ((< REG-ADR RAMME) 'M) ((< REG-ADR RAFSE) 'FS) ((< REG-ADR RAFDE) 'FD) ((< REG-ADR RAOPCE) 'OPC) ((< REG-ADR RARDRE) 'RAIDR) ((< REG-ADR RARGE) 'LAM) (T 'UNUSED))) (DEFPROP R LAM-REG-ADR-PHYS-MEM-OFFSET LAM-LOWEST-ADR) (DEFPROP C RACMO LAM-LOWEST-ADR) (DEFPROP D RADMO LAM-LOWEST-ADR) (DEFPROP P RAPBO LAM-LOWEST-ADR) (DEFPROP /1 RAM1O LAM-LOWEST-ADR) (DEFPROP /2C RAM2O-CONTROL LAM-LOWEST-ADR) (DEFPROP /2P RAM2O-PHYSICAL-PAGE LAM-LOWEST-ADR) (DEFPROP A RAAMO LAM-LOWEST-ADR) (DEFPROP U RAUSO LAM-LOWEST-ADR) (DEFPROP M RAMMO LAM-LOWEST-ADR) (DEFPROP FS RAFSO LAM-LOWEST-ADR) (DEFPROP FD RAFDO LAM-LOWEST-ADR) (DEFPROP LAM RARGO LAM-LOWEST-ADR) (DEFPROP CSW RACSWO LAM-LOWEST-ADR) (DEFPROP RAIDR RARDRO LAM-LOWEST-ADR) (DEFPROP OPC RAOPCO LAM-LOWEST-ADR) (DEFPROP MID RAMIDO LAM-LOWEST-ADR) (DEFPROP CAM RACAMO LAM-LOWEST-ADR) (DEFPROP R R LAM-@-NAME) (DEFPROP C C LAM-@-NAME) (DEFPROP D D LAM-@-NAME) (DEFPROP P P LAM-@-NAME) (DEFPROP /1 1 LAM-@-NAME) (DEFPROP /2C /2C LAM-@-NAME) (DEFPROP /2P /2P LAM-@-NAME) (DEFPROP A A LAM-@-NAME) (DEFPROP U U LAM-@-NAME) (DEFPROP M M LAM-@-NAME) (DEFPROP MID MID LAM-@-NAME) (DEFPROP CAM CAM LAM-@-NAME) (DEFUN LAM-PRINT-ADDRESS-1 (REG-ADR WD ITEMREST) WD ITEMREST (IF (NOT (ZEROP (LDB 2701 REG-ADR))) (SETQ REG-ADR (LOGIOR REG-ADR -100000000))) ;sign extend it! (LAM-PRINT-ADDRESS REG-ADR) (FORMAT T " ") (LAM-PRINT-ADDRESS REG-ADR T)) (DEFUN LAM-PRINT-ADDRESS (REG-ADR &OPTIONAL INHIBIT-SYMBOLS) (PROG (RANGE-NAME RANGE-BASE @-NAME TEM) (SETQ RANGE-NAME (LAM-FIND-REG-ADR-RANGE REG-ADR)) (COND ((AND (NULL INHIBIT-SYMBOLS) (SETQ TEM (LAM-FIND-CLOSEST-SYM REG-ADR)) (OR (ATOM TEM) (EQ RANGE-NAME 'C) (EQ RANGE-NAME 'D))) (PRIN1 TEM)) ((SETQ RANGE-BASE (GET RANGE-NAME 'LAM-LOWEST-ADR)) (COND ((SETQ @-NAME (GET RANGE-NAME 'LAM-@-NAME)) (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE))) (PRINC '@) (PRIN1 @-NAME)) (T (PRIN1 RANGE-NAME) (PRINC " ") (PRIN1 (- REG-ADR (SYMEVAL RANGE-BASE)))))) (T (PRIN1 REG-ADR))) X (RETURN T) )) (DEFVAR LAM-REGISTER-OP-TRACE NIL) (defun lam-register-examine (adr) (let ((val (cond ((closurep lam-access-path) (funcall lam-access-path :examine adr)) (t (lam-register-examine-guts adr))))) (COND ((MEMQ LAM-REGISTER-OP-TRACE '(T EXAMINE)) (FORMAT T "~%RD ") (LAM-PRINT-ADDRESS ADR) (FORMAT T ": ~s " VAL))) val)) (defun lam-register-examine-guts (adr) (COND ((>= ADR 0) (QF-MEM-READ ADR)) ((<= ADR LAM-REG-ADR-PHYS-MEM-TOP) (PHYS-MEM-READ (- ADR LAM-REG-ADR-PHYS-MEM-OFFSET))) ((< ADR RAFSO) ;RAMS (COND ((< ADR RAM2O-CONTROL) (COND ((< ADR RACME) (send *proc* :READ-C-MEM (- ADR RACMO))) ((< ADR RADME) (send *proc* :READ-D-MEM (- ADR RADMO))) ((< ADR RAPBE) (send *proc* :READ-PDL-BUFFER (- ADR RAPBO))) (T (send *proc* :read-l1-map (- ADR RAM1O))))) ((< ADR RAM2E-CONTROL) (send *proc* :read-l2-map-control (- ADR RAM2O-CONTROL))) ((< ADR RAM2E-PHYSICAL-PAGE) (send *proc* :read-l2-map-physical-page (- ADR RAM2O-PHYSICAL-PAGE))) ((< ADR RAAME) (send *proc* :READ-A-MEM (- ADR RAAMO))) ((< ADR RAUSE) (send *proc* :read-us (- ADR RAUSO))) ((< ADR RAMIDE) (send *proc* :READ-MID (- ADR RAMIDO))) ;macro.instruction.decode ram ((< ADR RACAME) (send *proc* :read-cam (- ADR RACAMO))) ((< ADR RAMME) (send *proc* :read-m-mem (- ADR RAMMO))) (T (FERROR NIL "lose")) )) ((< ADR RAFSE) ;FUNCTIONAL SOURCES (SETQ ADR (- ADR RAFSO)) (COND ((EQ LAM-LOW-LEVEL-FLAG 'VERY) (send *proc* :READ-M-MEM (+ ADR LAM-FUNC-SRC-INDICATOR))) ((= ADR COM-M-SRC-MD) (send *proc* :read-md)) ((= ADR COM-M-SRC-VMA) (send *proc* :read-vma)) ((= ADR COM-M-SRC-PDL-BUFFER-INDEX) (send *proc* :read-pi)) ((= ADR COM-M-SRC-C-PDL-BUFFER-INDEX) (send *proc* :read-pdl-buffer (send *proc* :read-pi))) (T (break "unknown func src")))) ((< ADR RAFDE) ;FUNCTIONAL DESTINATIONS (setq adr (- adr rafdo)) (cond ((= adr com-func-dest-pdl-buffer-index) (send *proc* :read-pi)) ((= adr com-func-dest-pdl-buffer-pointer) (send *proc* :read-pp)) ((= adr com-func-dest-md) (send *proc* :read-md)) ((= adr com-func-dest-vma) (send *proc* :read-vma)) (t (break "attempt to examine functional destination ~s" (PRINT (+ ADR RAFDO)))))) ((< ADR RAOPCE) (send *proc* :read-opc (- adr raopco))) ((< ADR RARGO) (format t "~s is among the unimplemented registers." adr) 0) ((<= ADR RARGE) ;INDIVIDUAL REGISTERS (COND ((= ADR RAPC) (send *proc* :READ-PC)) ((= ADR RAUSP) (send *proc* :read-usp)) ((= ADR RAIR) (send *proc* :READ-IREG)) ((= ADR RASIR) (send *proc* :read-ireg)) ((= ADR RAQ) (send *proc* :read-q-reg)) ((= ADR RALC) (send *proc* :read-lc)) ((= ADR RAMIR) (send *proc* :read-macro-ir)) ((= ADR RADC) (send *proc* :READ-DC)) ((= ADR RAMFO) (send *proc* :read-mfo)) ((= ADR RASTAT) (send *proc* :READ-STAT-COUNTER)) ((= ADR RASTAT-AUX) (send *proc* :READ-AUX-STAT-COUNTER)) ((= adr ramcr) (send *proc* :read-mcr)) ((= ADR RAGO) ;Determine whether the machine is currently running (COND ((AND LAM-RUNNING (NOT (LAM-HALTED))) 1) (T 0))) )) (T (format t "~s is an unassigned register address" adr) 0))) (DEFUN LAM-REGISTER-DEPOSIT (ADR DATA) (COND ((MEMQ LAM-REGISTER-OP-TRACE '(T DEPOSIT)) (FORMAT T "~%RD ") (LAM-PRINT-ADDRESS ADR) (FORMAT T ": ~s " DATA))) (COND ((CLOSUREP LAM-ACCESS-PATH) (FUNCALL LAM-ACCESS-PATH ':DEPOSIT ADR DATA)) ((>= ADR 0) (QF-MEM-WRITE ADR DATA)) ((<= ADR LAM-REG-ADR-PHYS-MEM-TOP) (PHYS-MEM-WRITE (- ADR LAM-REG-ADR-PHYS-MEM-OFFSET) DATA)) ((< ADR RAFSO) ;RAMS (COND ((< ADR RAM2O-CONTROL) (COND ((< ADR RACME) (send *proc* :WRITE-C-MEM (- ADR RACMO) DATA)) ((< ADR RADME) (send *proc* :WRITE-D-MEM (- ADR RADMO) DATA)) ((< ADR RAPBE) (send *proc* :WRITE-PDL-BUFFER (- ADR RAPBO) DATA)) ((AND (= ADR RAM1O) LAM-SAVED-LEVEL-1-MAP-LOC-0) (SETQ LAM-SAVED-LEVEL-1-MAP-LOC-0 DATA)) (T (send *proc* :WRITE-L1-MAP (- ADR RAM1O) DATA)))) ((< ADR RAM2E-CONTROL) (send *proc* :write-L2-MAP-CONTROL (- ADR RAM2O-CONTROL) DATA)) ((< ADR RAM2E-PHYSICAL-PAGE) (send *proc* :WRITE-LEVEL-2-MAP-PHYSICAL-PAGE (- ADR RAM2O-PHYSICAL-PAGE) DATA)) ((< ADR RAAME) (send *proc* :WRITE-A-MEM (- ADR RAAMO) DATA)) ((< ADR RAUSE) (send *proc* :WRITE-US (- ADR RAUSO) DATA)) ((< ADR RAMIDE) (send *proc* :WRITE-MID (- ADR RAMIDO) DATA)) ((< ADR RACAME) (send *proc* :WRITE-CAM (- ADR RACAMO) DATA)) ((< ADR RAMME) (send *proc* :WRITE-M-MEM (- ADR RAMMO) DATA)) (T (FERROR NIL "lose")))) ((< ADR RAFSE) ;FUNCTIONAL SOURCES (format t "~s attempt to deposit in functional source ignored" adr)) ((< ADR RAFDE) ;FUNCTIONAL DESTINATIONS (SETQ ADR (- ADR RAFDO)) (COND ((AND (NOT (EQ LAM-LOW-LEVEL-FLAG 'VERY)) (= ADR com-FUNC-DEST-MD)) (SETQ LAM-SAVED-MD DATA)) ((AND (NOT (EQ LAM-LOW-LEVEL-FLAG 'VERY)) (= ADR com-FUNC-DEST-VMA)) (SETQ LAM-VMA-CHANGED-FLAG T LAM-SAVED-VMA DATA)) ((AND (NOT (EQ LAM-LOW-LEVEL-FLAG 'VERY)) (= ADR com-FUNC-DEST-PI)) (SETQ LAM-SAVED-PDL-BUFFER-INDEX DATA)) ((= ADR com-FUNC-DEST-MD) (send *proc* :WRITE-MD DATA)) (T (send *proc* :write-func-dest adr data)) )) ((<= ADR RARGE) ;INDIVIDUAL REGISTERS (COND ((= ADR RAPC) (COND ((EQ LAM-LOW-LEVEL-FLAG 'VERY) (send *proc* :WRITE-PC (LOGAND 37777 DATA))) (T (SETQ LAM-SAVED-PC (LOGAND 37777 DATA))))) ((= ADR RAUSP) (LAM-SAVE-MICRO-STACK-PTR) (SETQ LAM-SAVED-MICRO-STACK-PTR (LOGAND 377 DATA))) ((= ADR RAIR) (send *proc* :write-ireg DATA)) ((= ADR RAQ) (send *proc* :WRITE-Q-REG DATA)) ((= ADR RALC) (send *proc* :WRITE-LC DATA)) ((= ADR RAMIR) (send *proc* :write-macro-ir data)) ((= ADR RADC) (send *proc* :WRITE-DC DATA)) ((= ADR RARS) (send *proc* :reset) ;(LAM-RESET-MACH) (SETQ LAM-PASSIVE-SAVE-VALID NIL LAM-FULL-SAVE-VALID NIL) (LAM-FULL-SAVE)) ((= ADR RASTEP) (lam-release-halt) (LAM-FULL-RESTORE) (LAM-STEP-MACH DATA) (LAM-FULL-SAVE)) ((= ADR RASTOP) (LAM-FULL-SAVE)) ;STOP & SAVE ((= ADR RASA) ;SET START ADDR (lam-release-halt) (SETQ LAM-NOOP-FLAG T LAM-SAVED-PC (LOGAND 177777 DATA))) ((= ADR RAGO) (lam-release-halt) (LAM-START-MACH)) ((= ADR RASTAT) (send *proc* :WRITE-STAT-COUNTER DATA)) ((= ADR RASTAT-AUX) (send *proc* :WRITE-AUX-STAT-COUNTER DATA)) (T (format t "~s is an unimplemented register - deposit." adr)))) (T (PRINT ADR) (PRINC "is an unassigned register address - deposit.")))) (defun lam-release-halt () (send *proc* :release-halt)) ;PHYSICAL MEMORY HACKING (DEFUN MEMORY-CONFIGURATION-INITIALIZE () (selectq (send *proc* :proc-type) (:lambda (get-memory-configuration-from-local-proc-conf (send *proc* :proc-conf-pointer)) ;(get-memory-configuration-from-sys-conf-structure ;this should work too. ; (send *proc* :proc-conf-bus-address)) ) (:explorer `((4000 ,(ash #xf4000000 -10.)) (4000 ,(ash #xf3000000 -10.)))))) (defun get-memory-configuration-from-sys-conf-structure (proc-conf) (declare (special %processor-conf-memory-bytes-0 %processor-conf-memory-base-0)) (let ( ;(proc-conf (proc-proc-conf-ptr *current-processor*)) ans) (dotimes (entry 10.) (let ((base-adr (bus-read (+ proc-conf (* 4 (+ %processor-conf-memory-base-0 entry))))) (size (bus-read (+ proc-conf (* 4 (+ %processor-conf-memory-bytes-0 entry)))))) (cond ((zerop base-adr) (return))) (cond ((not (zerop (ldb (byte 9. 1) base-adr))) ;sdu uses low bit as flag (FORMAT T "memory described in conf-memory-entry ~d. doesn't start at beginning of page" entry))) (setq ans (nconc ans (list (list (ash size -10.) (ash base-adr -10.))))) )) ans)) (defun get-memory-configuration-from-local-proc-conf (proc-p) (declare (special %processor-conf-memory-bytes-0 %processor-conf-memory-base-0)) (let ((ans nil)) (dotimes (entry 10.) (let ((base-adr (access-local-proc-conf proc-p (+ %processor-conf-memory-base-0 entry))) (size (access-local-proc-conf proc-p (+ %processor-conf-memory-bytes-0 entry)))) (cond ((zerop base-adr) (return))) (cond ((not (zerop (ldb (byte 8. 2) base-adr))) ;sdu uses low bit as flag (break "memory described in conf-memory-entry ~d. doesn't start at beginning of page" entry))) (setq ans (nconc ans (list (list (ash size -10.) (ash base-adr -10.))))))) ans)) (defun access-local-proc-conf (proc-p index) (dpb (aref proc-p (1+ (* index 2))) 2020 (aref proc-p (* index 2)))) (DEFUN PHYS-MEM-READ (ADR) (MULTIPLE-VALUE-BIND (QUAD-SLOT REL-ADR) (CADR-ADR-TO-NUBUS-QUAD-SLOT-AND-REL-ADR ADR) (funcall *proc* :bus-quad-slot-read QUAD-SLOT (ash REL-ADR 2)))) (DEFUN PHYS-MEM-WRITE (ADR VAL) (MULTIPLE-VALUE-BIND (QUAD-SLOT REL-ADR) (CADR-ADR-TO-NUBUS-QUAD-SLOT-AND-REL-ADR ADR) (funcall *proc* :bus-quad-slot-write QUAD-SLOT (ash REL-ADR 2) VAL)) T) (DEFUN NUBUS-PAGE-TO-HARDWARE-VIRTUAL-ADDRESS-PAGE (his-NUBUS-PAGE &aux local-nubus-page) "Translate 22 bit physical NUBUS PAGE to corresponding HARDWARE-VIRTUAL-ADDRESS. NIL if can not be referenced." (setq local-nubus-page (logxor (ash (or lam-phys-adr-convert 0) -10.) his-nubus-page)) (LET ((QUAD-SLOT (LDB 1610 local-NUBUS-PAGE)) (HARDWARE-VIRTUAL-ADDRESS-PAGE 0) (error-msg nil)) (DOLIST (E (SEND *PROC* :MEMORY-CONFIGURATION-LIST) (ferror nil (if (null error-msg) "~%Ref to incorrect quad-slot ~s" error-msg) quad-slot)) (COND ((= QUAD-SLOT (ldb 1610 (CADR E))) ;right card. (let ((rel-page (- (LDB 0016 local-NUBUS-PAGE) (ldb 0016 (cadr e))))) ;There can be more than one block in a single memory card, so dont error out immediately ; if it seems to be out of range. (COND ((< rel-page 0) (setq error-msg "~%Ref to lower in card than allocated. quad-slot ~s")) ((>= REL-PAGE (CAR E)) (setq error-msg "~%Ref to higher in card than allocated. quad-slot ~s")) (t (RETURN (+ HARDWARE-VIRTUAL-ADDRESS-PAGE REL-PAGE))))))) (SETQ HARDWARE-VIRTUAL-ADDRESS-PAGE (+ HARDWARE-VIRTUAL-ADDRESS-PAGE (CAR E)))))) (DEFUN CADR-ADR-TO-NUBUS-QUAD-SLOT-AND-REL-ADR (ADR) (LET ((NUBUS-PAGE (CADR-PAGE-TO-NUBUS-PAGE (LDB 1020 ADR)))) ;altogether, nubus address is 8 quad-slot, 14 page number, 8 within page, 2 byte. (VALUES (LDB #.(byte 8 (- 24. 10.)) NUBUS-PAGE) ;quad-slot (+ (LSH (LDB #.(byte 14. 0.) NUBUS-PAGE) 8) (LOGAND ADR 377))))) (DEFUN CADR-PAGE-TO-NUBUS-PAGE (CADR-PAGE) (DO ((P (SEND *PROC* :MEMORY-CONFIGURATION-LIST) (CDR P)) (PAGE CADR-PAGE)) ((NULL P) (FERROR NIL "UNABLE TO MAP PAGE")) (COND ((< PAGE (FIRST (CAR P))) (RETURN (+ (SECOND (CAR P)) PAGE)))) (SETQ PAGE (- PAGE (FIRST (CAR P)))))) (defun total-pages-of-memory (&aux (total 0)) (dolist (x (send *proc* :memory-configuration-list)) (incf total (car x))) total) ;lam- routines for reading and writing various memories. In most cases, these are ; identical to non lam- routines, but in some cases they may save status to avoid ; side effects, etc. (defun lam-read-m-mem (adr) (send *proc* :read-m-mem adr)) (defun lam-write-m-mem (adr data) (send *proc* :write-m-mem adr data)) (defun lam-read-a-mem (adr) (send *proc* :read-a-mem adr)) (defun lam-write-a-mem (adr data) (send *proc* :write-a-mem adr data)) (defun lam-read-c-mem (adr) (send *proc* :read-c-mem adr)) (defun lam-write-c-mem (adr data) (send *proc* :write-c-mem adr data)) (defun lam-read-md () (send *proc* :read-md)) (defun lam-write-md (data) (send *proc* :write-md data)) (defun lam-read-vma () (send *proc* :read-vma)) (defun lam-write-vma (data) (send *proc* :write-vma data)) (DEFUN LAM-READ-PDL-BUFFER (ADR) (send *proc* :read-pdl-buffer adr)) (DEFUN LAM-WRITE-PDL-BUFFER (ADR DATA) (send *proc* :write-pdl-buffer adr data)) (DEFun LAM-READ-PC () (send *proc* :read-pc)) (defun lam-write-pc (n) (send *proc* :write-pc n)) (DEFUN LAM-READ-LEVEL-1-MAP (ADR) (send *proc* :read-l1-map adr)) (DEFUN LAM-WRITE-LEVEL-1-MAP (ADR DATA) (send *proc* :write-l1-map adr data)) (DEFUN LAM-READ-LEVEL-2-MAP-CONTROL (ADR) (send *proc* :read-l2-map-control adr)) (DEFUN LAM-WRITE-LEVEL-2-MAP-CONTROL (ADR DATA) (send *proc* :write-l2-map-control adr data)) (DEFUN LAM-READ-LEVEL-2-MAP-PHYSICAL-PAGE (ADR) (send *proc* :read-l2-map-physical-page adr)) (DEFUN LAM-WRITE-LEVEL-2-MAP-PHYSICAL-PAGE (ADR DATA) (send *proc* :write-l2-map-physical-page adr data)) (defun LAM-READ-MICRO-STACK-PTR () (send *proc* :read-usp)) (DEFun LAM-WRITE-MICRO-STACK-PTR (data) (send *proc* :WRITE-USP data)) (defun lam-read-lc () (send *proc* :read-lc)) (defun lam-write-lc (data) (send *proc* :write-lc data)) (defun lam-read-macro-ir () (send *proc* :read-macro-ir)) (defun lam-write-macro-ir (data) (send *proc* :write-macro-ir data)) (defun lam-read-stat-counter () (send *proc* :read-stat-counter)) (defun lam-write-stat-counter (data) (send *proc* :write-stat-counter data)) (defun lam-read-aux-stat-counter () (send *proc* :read-aux-stat-counter)) (defun lam-write-aux-stat-counter (data) (send *proc* :write-aux-stat-counter data)) (defun lam-read-dispatch-constant () (send *proc* :read-dc)) (defun lam-write-dispatch-constant (data) (send *proc* :write-dc data)) (DEFUN LAM-READ-MID (ADR) (send *proc* :read-mid adr)) (DEFUN LAM-WRITE-MID (ADR DATA) (send *proc* :write-mid adr data)) (defun lam-read-cram-adr-map (adr) (send *proc* :read-cam adr)) (defun lam-write-cram-adr-map (adr data) (send *proc* :write-cam adr data)) ;must return micro-stack-ptr (defun lam-save-micro-stack-ptr () (if (null lam-saved-micro-stack-ptr) (setq lam-saved-micro-stack-ptr (lam-read-micro-stack-ptr))) lam-saved-micro-stack-ptr) (defun lam-save-level-1-map-loc-0 () (send *proc* :save-l1-map-0))