;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Lowercase:T -*-

(defmacro pte-pfn (pte)
  `(logand #xfffffc00 ,pte))

(defmacro pte-modified (pte)
  `(ldb (byte 1 0) ,pte))

(defmacro pte-accessed (pte)
  `(ldb (byte 1 1) ,pte))

(defmacro pte-valid (pte)
  `(ldb (byte 1 2) ,pte))

(defmacro pte-cache (pte)
  `(ldb (byte 1 3) ,pte))

(defmacro pte-access (pte)
  `(ldb (byte 2 4) ,pte))

(defmacro pte-fill-on-demand (pte)
  `(ldb (byte 1 6) ,pte))

(defmacro pte-swap-needed (pte)
  `(ldb (byte 1 7) ,pte))

(defmacro pte-soft-modified (pte)
  `(ldb (byte 1 8) ,pte))

(defmacro pte-spare (pte)
  `(ldb (byte 1 9) ,pte))

(defun 68-describe-pte (pte)
  (format t "~&PTE = ~o" pte)
  (format t "~&Page frame number = ~o (phys adr ~:*~16r)" (pte-pfn pte))
  (format t "~&Spare = ~o" (pte-spare pte))
  (format t "~&Soft Modified = ~o" (pte-soft-modified pte))
  (format t "~&Need to swap = ~o" (pte-swap-needed pte))
  (format t "~&Fill on demand = ~o" (pte-fill-on-demand pte))
  (format t "~&Access = ~o ~a" (pte-access pte)
	  (selectq (pte-access pte)
	    (0 "Kernel read")
	    (1 "Kernel write")
	    (2 "User read, Kernel write")
	    (3 "User write")))
  (format t "~&Cache = ~o" (pte-cache pte))
  (format t "~&Valid = ~o" (pte-valid pte))
  (format t "~&Touched = ~o" (pte-accessed pte))
  (format t "~&Modified = ~o" (pte-modified pte))
  )

(defun 68-describe-pte-short (pte)
  (cond ((zerop (pte-valid pte))
	 (format t "NOT-VALID"))
	(t
	 (format t "~16,8r ~s" (pte-pfn pte)
		 (selectq (pte-access pte)
		   (0 "KR")
		   (1 "KW")
		   (2 "URKW")
		   (3 "UW"))))))

(defun 68-describe-ptes (ary)
  (dotimes (i (array-length ary))
    (let ((pte (aref ary i)))
      (if (zerop (ldb 0002 i))
	  (format t "~&"))
      (format t "~0,16t")
      (68-describe-pte-short pte))))

(defun 68-describe-pages ()
  (dotimes (l1 100)
    (cond ((not (zerop (aref 68-1 l1)))
	   (format t "~&~16r:" (ash (* l1 256.) 10.))
	   (dotimes (i 256.)
	     (if (zerop (ldb 0002 i))
		 (format t "~&"))
	     (format t "~0,16t")
	     (68-describe-pte-short (aref 68-2 (+ (* l1 256.) i)))
	     )))))

(defun find-pages-not-on-board (board)
  (dotimes (i (array-length 68-2))
    (cond ((not (zerop (aref 68-2 i)))
	   (let ((b (ldb (byte 4. 24.) (pte-pfn (aref 68-2 i)))))
	     (cond ((not (= board b))
		    (format t "~16r " (aref 68-2 i)))))))))

(defun find-pages-on-board (board)
  (dotimes (i (array-length 68-2))
    (cond ((not (zerop (aref 68-2 i)))
	   (let ((b (ldb (byte 4. 24.) (pte-pfn (aref 68-2 i)))))
	     (cond ((= board b)
		    (format t "~16r " (aref 68-2 i)))))))))

(defvar 68-beginning-of-first-level-map #x3e400)
(defvar 68-prime-memory #xa)

;(defun 68-first-level-map-phys-adr ()
;  (+ #xf0000000
;     (ash 68-prime-memory 24.)
;     68-beginning-of-first-level-map))

(defun 68-first-level-map-phys-adr ()
    (nd-bus-read-68-swap #xfb081904))

(defun 68-print-first-level-map ()
  (dotimes (x 100)
    (if (zerop (ldb 0003 x))
	(format t "~&"))
    (format t "~16,8r " (aref 68-1 x))))

(defun nd-bus-read-68-swap (adr)
  (let ((data (nd-bus-read adr)))
    (dpb (ldb (byte 8 0) data)
	 (byte 8 24.)
	 (dpb (ldb (byte 8 8) data)
	      (byte 8 16.)
	      (dpb (ldb (byte 8 16.) data)
		   (byte 8 8)
		   (ldb (byte 8 24.) data))))))


(defvar 68-1 (make-array 100))
(defvar 68-2 (make-array (* 100 256.)))

(defun read-68-state ()
  (fillarray 68-2 nil)
  (let ((adr (68-first-level-map-phys-adr)))
    (do ((level-1 0 (1+ level-1))
	 (level-2-offset 0 (+ level-2-offset 256.)))
	((= level-1 100))
      (let ((pte (nd-bus-read-68-swap (+ adr (* 4 level-1)))))
	(aset pte 68-1 level-1)
	(cond ((zerop pte)
	       (dotimes (x 256.)
		 (aset 0 68-2 (+ level-2-offset x))))
	      (t
	       (let ((pfn (pte-pfn pte)))
		 (dotimes (x 256.)
		   (aset (nd-bus-read-68-swap (+ pfn (* x 4)))
			 68-2
			 (+ level-2-offset x)))))))))
    )


(defvar intmap-base #xfd07e400)

(defun set-intmap-base ()
  (setq intmap-base (si:%system-configuration-sdu-interrupt-map si:*sys-conf*)))

(defconst sdu-interrupts '(( 0 . "div 0")
			   ( 1 . "trace")
			   ( 2 . "nmi")
			   ( 3 . "int3")
			   ( 4 . "overflow")
			   ( 5 . "??5")
			   ( 6 . "??6")
			   ( 7 . "??7")
			   (10 . "multibus timeout")
			   (11 . "nubus timeout")
			   (12 . "quart exception")
			   (13 . "quart ready")
			   (14 . "power fail")
			   (15 . "8087")
			   (16 . "PIC-2")
			   (17 . "PIC-1")
			   (20 . "serial A rcv")
			   (21 . "serial A xmit")
			   (22 . "serial B rcv")
			   (23 . "serial B xmit")
			   (24 . "PIT 0 unix clock")
			   (25 . "PIT 1")
			   (26 . "PIT 2 sdu clock")
			   (27 . " unused")
			   (30 . "m0 3COM")
			   (31 . "m1 IOMSG")
			   (32 . "m2 tapemaster")
			   (33 . "m3 unused")
			   (34 . "m4 disk")
			   (35 . "m5 unused")
			   (36 . "m6 MTI")
			   (37 . "m7 share")))

(defun print-intmap ()
  (dotimes (i 32.)
    (print-one-intmap i)))

; type:32 addr:32 ds:16 pic:16
(defun print-one-intmap (index)
  (let* ((addr (+ intmap-base (* 16. index)))
	 (im-type (nd-bus-read-byte addr))
	 (im-addr (nd-bus-read (+ addr 4)))
	 (im-ds (nd-bus-read-16 (+ addr 8)))
	 (im-pic (nd-bus-read-16 (+ addr 10.))))
    (format t "~%intmap ~16,2r at ~16,8r: " index addr)
    (format t "~20a " (cdr (assq index sdu-interrupts)))
    (selectq im-type
      (0 (format t "NONE addr=~16r ds=~16r pic=~16r" im-addr im-ds im-pic))
      (1 (format t "SDU addr=~16r ds=~16r pic=~16r" im-addr im-ds im-pic))
      (2 (format t "NUBUS sdu-addr=~16r nu-addr=~16r ds=~16r pic=~16r"
		   im-addr (read-8086-multibus-address (+ addr 4)) im-ds im-pic))
      (t (format t "type=~16r addr=~16r ds=~16r pic=~16r" im-type im-addr im-ds im-pic)))))

 		   ;    (prnu (+ (* i 24) 37501762000) 5)))

(defun nd-bus-read-16 (addr)
  (dpb (nd-bus-read-byte (+ 1 addr))
       (byte 8 8)
       (nd-bus-read-byte addr)))

#|
(defun nd-bus-read-byte (addr)
  (let ((byte-no (ldb (byte 2 0) addr))
	(slot (ldb (byte 8 24.) addr))
	(offset (logand addr #xfffffc)))
    (logand #xff (ash (%nubus-read slot offset) (* byte-no -8)))))

(defun nd-bus-read (addr)
  (let ((slot (ldb (byte 8 24.) addr))
	(offset (logand addr #xfffffc)))
    (%nubus-read slot offset)))
|#

(defun prnu (addr n)
  (dotimes (i n)
           (format t "~%~16r: ~16r" (+ addr (* 4 i)) (nd-bus-read (+ (* 4 i) addr)))))


(defun print-sdu-status ()
  (print-sdu-reg0)
  (print-sdu-reg1)
  (print-sdu-intreg)
  (print-sdu-bus-timeout-reg))

(defun print-sdu-reg0 ()
  (print-word-as-bits "sdu-csr-0" (nd-bus-read-byte #xff01c08c)
		      '("mbus-enab" "nubus-enab" "timeout-enab" "slow-clock"
			"fast-clock" nil nil)))

(defun print-sdu-reg1 ()
  (print-word-as-bits "sdu-csr-1" (nd-bus-read-byte #xff01c088)
		      '("qtr-ready" "nubus-reset" "mbus-reset" "qtr-reset"
			"qtr-req" "qtr-online" "qtr-exc")))

(defun print-sdu-intreg ()
  (format t "~%sdu-intreg=~16r" (nd-bus-read-byte #xff01c1e0)))

(defun print-sdu-bus-timeout-reg ()
  (format t "~%sdu-bus-timeout-reg=~16r" (nd-bus-read-byte #xff01c180)))

(defun print-pics ()
  (dotimes (i 3)
    (print-one-pic i)))

(defun print-one-pic (index)
  (let ((addr (+ #xff01c1c0 (* index 8))))
	(format t "~%pic~16r at ~16r: " index addr)
	(format t "mask=~16r " (nd-bus-read-byte (+ addr 4)))
	(nd-bus-write-byte addr #xa)
	(format t "irr=~16r " (nd-bus-read-byte addr))
	(nd-bus-write-byte addr #xb)
	(format t "isr=~16r " (nd-bus-read-byte addr))))

(defun print-68k-status ()
  (let ((cpu-addr #xfb000000))			;temporary; replace with sysconfig
    (print-68k-cfreg cpu-addr)
    (print-68k-cpuctl cpu-addr)
    (print-68k-syscid cpu-addr)
    (print-68k-usrcid cpu-addr)
    (print-68k-cachectl cpu-addr)
    (print-68k-cachehit cpu-addr)
    (print-68k-errors cpu-addr)
    (print-68k-parity cpu-addr)
    (print-68k-cpufnc cpu-addr)
    (print-68k-vaddr cpu-addr)
    (print-68k-paddr cpu-addr)
    (print-68k-pbr cpu-addr)))

(defun print-68k-cpuctl (cpu-addr)
  (print-word-as-bits "cpuctl" (nd-bus-read-byte (+ cpu-addr #xe80000))
		      '("pri-stop" nil "select" "sstep" "pri-halt" nil
			"bus-err-on-restart")))

(defun print-68k-syscid (cpu-addr)
  (format t "~%sys-cache-id=~16r" (nd-bus-read-byte (+ cpu-addr #xe80004))))

(defun print-68k-usrcid (cpu-addr)
  (format t "~%usr-cache-id=~16r" (nd-bus-read-byte (+ cpu-addr #xe80008))))

(defun print-68k-cachectl (cpu-addr)
  (print-word-as-bits "cache-ctl" (nd-bus-read-byte (+ cpu-addr #xe8000c))
		      '("trans" "parity" "tlb1-low" "tlb1-hi" "tlb2-low" "tlb2-hi"
			"cache-low" "cache-hi")))

(defun print-68k-cachehit (cpu-addr)
  (print-word-as-bits "cache-hit" (nd-bus-read-byte (+ cpu-addr #xe80010))
		      '("cachehit" "tlb1-hit" "tlb2-hit")))

(defun print-68k-errors (cpu-addr)
  (print-word-as-bits "errors" (nd-bus-read-byte (+ cpu-addr #xe80014))
		      '("tm0" "tm1" "pbr-parity-err" "invalid-pte" "access"
			nil "ram-parity-err" "multiple-err")))

(defun print-68k-parity (cpu-addr)
  (print-word-as-bits "parity" (nd-bus-read-byte (+ cpu-addr #xe80015))
		      '(("parity-err" 2) ("parity-bits" 6))))

(defun print-68k-cpufnc (cpu-addr)
  (print-word-as-bits "cpufnc" (nd-bus-read-byte (+ cpu-addr #xe80016))
		      '("fc0" "fc1" "fc2" "cpurw" "lds" "uds" "ud8" "level-1-p")))

(defun print-68k-busfnc (cpu-addr)
  (print-word-as-bits "busfnc" (nd-bus-read-byte (+ cpu-addr #xe80017))
		      '("ad0" "ad1" "tm0" "tm1" "uw" "ur" "sw" "sr")))

(defun print-68k-vaddr (cpu-addr)
  (format t "~%vaddr=~16r" (logand (nd-bus-read (+ cpu-addr #xe80018)) #xffffff)))

(defun print-68k-paddr (cpu-addr)
  (format t "~%paddr=~16r" (nd-bus-read (+ cpu-addr #xe8001c))))

(defun print-68k-cfreg (cpu-addr)
  (print-word-as-bits "cfreg" (nd-bus-read-byte (+ cpu-addr #xf00000))
		      '("reset" "enable" "led")))

(defun print-68k-pbr (cpu-addr)
  (format t "~%pbr's: ")
  (print-n-swapped-words (+ cpu-addr #x81900) 8))

(defun print-n-swapped-words (addr n)
  (dotimes (i n)
    (format t "~16r " (nd-bus-read-68-swap addr))
    (setq addr (+ addr 4))))

(defun print-word-as-bits (name word string-list)
  (format t "~%~a: " name)
  (dolist (x string-list)
    (cond ((atom x)
	   (cond ((not (equal x nil))
		  (format t "~a=~16r " x (logand word 1))))
	   (setq word (ash word -1)))
	  (t
	   (let ((size (cadr x)))
	     (format t "~a=~16r " (car x) (ldb (byte size 0) word))
	     (setq word (ash word (- size))))))))

(defvar sdu-cmos-ram (make-array 2048.))
(defvar sdu-cmos-ram-array-valid 0)

(defun read-cmos-ram-into-array ()
  (dotimes (i 2048)
    (aset (nd-bus-read-byte (+ #xff01e000 (* i 4))) sdu-cmos-ram i))
  (setq sdu-cmos-ram-array-valid 1))

(defun write-cmos-ram-from-array ()
  (cond ((zerop sdu-cmos-ram-array-valid)
	 (format t "~%cmos ram hasn't been read in."))
	(t
	 (dotimes (i 2048)
	   (nd-bus-write-byte (+ #xff01e000 (* i 4)) (aref sdu-cmos-ram i))))))

(defconst cmos-ram-file "lm1:lambda-diag;sdu-cmos-ram.qfasl")

(defun save-cmos-ram ()
  (compiler:fasd-symbol-value cmos-ram-file 'sdu-cmos-ram))

(defun restore-cmos-ram ()
  (load cmos-ram-file))


; stuff for sdu newboot

;symbol table from a.out
;jumps indirect through data ptr
; seg in jmp addr rel to ds=0, reloc by loaded ds
; seg in ptr rel to cs=0, reloc by loaded cs
; need to know prog cs, ds, ss

;print int vectors
;mem alloc list
;proc structure
;driver structure

;seg:offs
;hi-16 is seg, low-16 is offset
(defun print-86-ptr (word)
  (format t "~16r:~16r" (ldb (byte 16. 16.) word) (ldb (byte 16. 0) word)))

; 0: 00:03
; 4: 00:22

(defun print-n-86-ptrs (addr n)
  (dotimes (i n)
    (format t "~%~16r: " addr)
    (print-86-ptr (nd-bus-read addr))
    (setq addr (+ addr 4))))

;ptr is seg:offs
;(defun sdu-read (ptr)
; returns word from mem  (read-8086-multibus-address

;(defun sdu-ptr-to-nubus-addr (ptr)
;  "get effective nubus addr by reffing ptr (seg:offs) through sdu-to-nubus map if required"
;  (let ((maddr (8086-ptr-to-multibus-address ptr)))
;    ()))

;in smd-disk ...
;(defun read-8086-multibus-address (nubus-pointer-location)

(defun print-sdu-map ()
  (dotimes (i 1024.)
    (print-multibus-mapping-register i)))

#|

(defun read-8086-multibus-address (nubus-pointer-location)
  (let ((multibus-address
	  (8086-ptr-to-multibus-address
	    (cond ((zerop (ldb 0002 nubus-pointer-location))
		   (nd-bus-read nubus-pointer-location))
		  (t
		   (logior (nd-bus-read-byte nubus-pointer-location)
			   (ash (nd-bus-read-byte (+ nubus-pointer-location 1)) 8)
			   (ash (nd-bus-read-byte (+ nubus-pointer-location 2)) 16.)
			   (ash (nd-bus-read-byte (+ nubus-pointer-location 3)) 24.)))))))
    (values (map-multibus-address multibus-address) multibus-address)))

(defun map-multibus-address (nubus-address)
  "return nubus-address, unless it points to the multibus, and is mapped to the nubus.
in that case, follow the mapping, and return that address"
  (cond ((not (= (ldb (byte 8 24.) nubus-address) #xff))
	 nubus-address)
	(t
	 (let ((map-to (fs:read-multibus-mapping-register (ldb 1212 nubus-address))))
	   (cond ((ldb-test 2701 map-to)	; check valid bit
		  (dpb (ldb 0026 map-to)
		       (byte 22. 10.)
		       (ldb (byte 10. 0) nubus-address)))
		 (t
		  nubus-address))))))

(defun 8086-ptr-to-multibus-address (ptr)
  (+ (ash (ldb (byte 16. 16.) ptr) 4)
     (ldb (byte 16. 0) ptr)
     #xff000000))

|#