; -*- Mode:Lisp; Package:LAMBDA; Base:8; readtable: ZL -*-
;DISK HANDLER FOR LAM FOR LAMBDA
;    ** (c) Copyright 1980 - Massachusetts Institute of Technology
;    ** (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.


;******************************
; STILL TO BE DONE
; <HAIRIER> FUNCTION TO VERIFY PAGE HASH TABLE, ALSO MAP?
;******************************

(DECLARE (SPECIAL LAM-DISK-ADDRESS LAM-DISK-RETRY-COUNT
		  LAM-DISK-DA-DESC LAM-DISK-STATUS-DESC LAM-DISK-CMD-DESC
		  LAM-DISK-READ-FCN LAM-DISK-WRITE-FCN
		  LAM-DISK-TRACE-FLAG LAM-DISK-LAST-CMD LAM-DISK-LAST-CLP
		  %SYS-COM-PAGE-TABLE-PNTR %SYS-COM-PAGE-TABLE-SIZE
		  %%PHT1-VALID-BIT %%QF-PHT1-VIRTUAL-PAGE-NUMBER
		  %%PHT2-PHYSICAL-PAGE-NUMBER
		  %%PHT1-SWAP-STATUS-CODE %PHT-SWAP-STATUS-PDL-BUFFER 
		  %PHT-SWAP-STATUS-WIRED %PHT-SWAP-STATUS-FLUSHABLE
		  %%PHT2-MAP-STATUS-CODE %%PHT2-ACCESS-STATUS-AND-META-BITS
		  %PHT-MAP-STATUS-READ-WRITE %PHT-MAP-STATUS-PDL-BUFFER
		  %PHT-DUMMY-VIRTUAL-ADDRESS
		  MICRO-CODE-SYMBOL-AREA-START MICRO-CODE-SYMBOL-AREA-END
		  PHT-ADDR
		  INITIAL-LOD-NAME N-PARTITIONS
		  N-HEADS N-CYLINDERS N-BLOCKS-PER-TRACK
		  BLOCKS-PER-TRACK BLOCKS-PER-CYLINDER LAM-DISK-TYPE
		  PARTITION-NAMES PARTITION-START PARTITION-SIZE 
		  CTALK-BARF-AT-WRITE-ERRORS))

(SETQ MICRO-CODE-SYMBOL-AREA-START 3  ;MAGIC
      MICRO-CODE-SYMBOL-AREA-END 7)   ;MORE MAGIC

(SETQ LAM-DISK-RETRY-COUNT 5)	;TIMES TO RETRY AT LAM-DISK-XFER IF GET ERROR
;(SETQ LAM-DISK-LAST-CMD 0 LAM-DISK-LAST-CLP 777) ;AVOID UNBOUND

(SETQ LAM-DISK-TRACE-FLAG NIL)



(DEFUN LAM-DISK-ANALYZE ()
    (PRINT-IOPB)
)

;Look at the disk error log of the machine on the other end of the debug interface
(DEFUN LAM-PRINT-DISK-ERROR-LOG ()
  (DO I 600 (+ I 4) (= I 640)
    (LET ((CLP-CMD (PHYS-MEM-READ I))
	  (DA (PHYS-MEM-READ (1+ I)))
	  (STS (PHYS-MEM-READ (+ I 2)))
	  (MA (PHYS-MEM-READ (+ I 3))))
      (COND ((NOT (ZEROP CLP-CMD))
	     (FORMAT T "~%Command ~O ~@[(~A) ~]"
		       (LOGLDB 0020 CLP-CMD)
		       (CDR (ASSQ (LOGLDB 0004 CLP-CMD) '((0 . "Read")
							  (10 . "Read-Compare")
							  (11 . "Write")))))
	     (FORMAT T "CCW-list pointer ~O (low 16 bits)~%" (LOGLDB 2020 CLP-CMD))
	     (FORMAT T "Disk address: unit ~O, cylinder ~O, head ~O, block ~O (~4:*~D ~D ~D ~D decimal)~%"
		       (LOGLDB 3404 DA) (LOGLDB 2014 DA) (LOGLDB 1010 DA) (LOGLDB 0010 DA))
	     (FORMAT T "Memory address: ~O (type bits ~O)~%"
		       (LOGLDB 0026 MA) (LOGLDB 2602 MA))
	     (FORMAT T "Status: ~O" STS)
	     (DO ((PPSS 2701 (- PPSS 100))
		  (L '("Internal-parity" "Read-compare" "CCW-cycle" "NXM" "Mem-parity"
		       "Header-Compare" "Header-ECC" "ELAM-Hard" "ECC-Soft"
		       "Overrun" "Transfer-Aborted (or wr. ovr.)" "Start-Block-Error"
		       "Timeout" "Seek-Error" "Off-Line" "Off-Cylinder"
		       "Read-Only" "Fault" "No-Select" "Multiple-Select"
		       "Interrupt" "Sel-Unit-Attention" "Any-Unit-Attention" "Idle")
		     (CDR L)))
		 ((MINUSP PPSS) (TERPRI))
	       (AND (LDB-TEST PPSS STS) (FORMAT T "~<~%~8X~:;  ~A~>" (CAR L)))))))))


;Try harder routine.
;Get CYL, Head, Sector from disk, or from &OPTIONAL args.
;Try xfer again, with all flavors of offsets, and report.
;Then try recalibrate, all offsets again.

(defun lam-try-harder (&OPTIONAL CYL head sector
		       &aux (unit 0) disk-adr) disk-adr unit sector head cyl
  (BREAK "FOO")
  (COMMENT
    (cond ((null cyl)				;default from last xfer
	   (setq disk-adr (phys-mem-read (+ lam-disk-address 2)))
	   (setq cyl (ldb 2014 disk-adr)
		 head (ldb 0808 disk-adr)
		 sector (ldb 0008 disk-adr)
		 unit (ldb 3403 disk-adr))))
    (do recal 0 (1+ recal) (= recal 2)
	(do ((fcn-bits '(0 40 60 100 200 140 240 160 260) (cdr fcn-bits))
	     (fcn-name '("Normal" "Servo Reverse" "Servo Forward"
			 "Strobe Early" "Strobe Late"
			 "Servo Reverse -- Strobe Early"	;NO COMMAS INSIDE STRINGS
			 "Servo Reverse -- Strobe Late"	; IN MACLISP
			 "Servo Forward -- Strobe Early"
			 "Servo Forward -- Strobe Late")
		       (cdr fcn-name))
	     (lam-disk-retry-count 1))		;for lam-disk-xfer-...
	    ((null fcn-bits))
	  (format t "~%Trying with ~A ---" (car fcn-name))
	  ;; Read that block into core page 3
	  
	  (phys-mem-write 1400 525252777)	;change data
	  (SMD-SEEK 800.)			;random seek of cylinder
	  (lam-disk-xfer-track-head-sector (car fcn-bits) cyl head sector 3 1)
	  (lam-disk-op 6)			;Clear servo offset
;           (compare)
	  )
	(cond ((= recal 0)
	       (format t "~%[Recalibrating]")
	       (lam-disk-op 1005)		;Recalibrate
	       (lam-disk-wait-idle 4)		;wait Sel Unit Attention - recal done
	       )))))


(defun lam-disk-recalibrate nil 
  (BREAK "FOO")
  )

;;; THESE ARE REALLY ONLY USED FOR READING THE LABEL
;;; DEFAULT TO eagle (formated at 512 bytes per sector)
; unfortunately sectors-per-track is defined in smd-disk.lisp - I hope it
; doesn't cause problems to use it here.
(DEFCONST BLOCKS-PER-TRACK SECTORS-PER-TRACK)
(DEFCONST BLOCKS-PER-CYLINDER (* SECTORS-PER-TRACK 20.))
;(DEFCONST LAM-DISK-TYPE NIL)

;;; INITIALIZES DISK PARAMETERS
(DEFUN LAM-DISK-INIT ()
   ;  (LET ((LAM-DISK-TYPE T)))
  (READ-LABEL)
  (cond ((or (zerop n-heads)
	     (zerop n-blocks-per-track))
	 (ferror nil "n-heads=~s, n-blocks-per-track=~s, you will lose badly"
		 n-heads n-blocks-per-track)))
;  (SETQ BLOCKS-PER-CYLINDER (* N-HEADS N-BLOCKS-PER-TRACK))
;  (SETQ BLOCKS-PER-TRACK N-BLOCKS-PER-TRACK)
;  (SETQ LAM-DISK-TYPE T)
  )

(defun lam-fake-disk-init-for-t302 ()
  (setq n-heads 19.)
  (setq n-blocks-per-track 18.)
;  (SETQ BLOCKS-PER-CYLINDER (* N-HEADS N-BLOCKS-PER-TRACK))
;  (SETQ BLOCKS-PER-TRACK N-BLOCKS-PER-TRACK)
;  (SETQ LAM-DISK-TYPE T)
  )

;SAME AS LAM-DISK-XFER, BUT TAKES ARGS IN TRACK, HEAD, SECTOR FORM.
; MAINLY GOOD FOR RETRYING TRANSFERS THAT LOSE, ETC.
(DEFUN LAM-DISK-XFER-TRACK-HEAD-SECTOR (FCN TRACK HEAD SECTOR MB-ADR N-BLOCKS)
  fcn track head sector mb-adr n-blocks
 (ferror nil "can't work")
 (comment
  (LAM-DISK-XFER FCN (LIST TRACK HEAD SECTOR) MB-ADR N-BLOCKS) ) )


(DEFUN LAM-DISK-READ-VIA-MULTIBUS (DISK-BLOCK-NUM MB-ADR N-BLOCKS)
  ;(ferror nil "obsolete")
  (IF LAM-DISK-TRACE-FLAG
      (FORMAT T "~%LAM-DISK-READ-VIA-MULTIBUS block ~s mb-adr ~s nblocks ~s"
	      DISK-BLOCK-NUM MB-ADR N-BLOCKS))
  (LAM-DISK-XFER-VIA-MULTIBUS SMD-READ-COMMAND DISK-BLOCK-NUM MB-ADR N-BLOCKS))

(DEFUN LAM-DISK-READ-VIA-NUBUS (DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS)
  (IF LAM-DISK-TRACE-FLAG
      (FORMAT T "~%LAM-DISK-READ-VIA-NUBUS block ~s core-page-num ~s nblocks ~s"
	      DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS))
  (selectq current-processor-type
    (:lambda (LAM-DISK-XFER-VIA-NUBUS SMD-READ-COMMAND DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS))
    (:explorer
     (cond ((= n-blocks 1)
	    (nupi-read (send *proc* :page-band-unit) disk-block-num core-page-num n-blocks))
	   (t
	    (ferror nil "foo"))))))
  
(DEFUN LAM-DISK-WRITE-VIA-MULTIBUS (DISK-BLOCK-NUM MB-ADR N-BLOCKS)
  (ferror nil "obsolete")
  (IF LAM-DISK-TRACE-FLAG
      (FORMAT T "~%LAM-DISK-WRITE-VIA-MULTIBUS block ~s mb-adr ~s nblocks ~s"
	      DISK-BLOCK-NUM MB-ADR N-BLOCKS))
  (LAM-DISK-XFER-VIA-MULTIBUS SMD-WRITE-COMMAND DISK-BLOCK-NUM MB-ADR N-BLOCKS))

(DEFUN LAM-DISK-WRITE-VIA-NUBUS (DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS)
  (IF LAM-DISK-TRACE-FLAG
      (FORMAT T "~%LAM-DISK-WRITE-VIA-NUBUS block ~s core-page-num ~s nblocks ~s"
	      DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS))
  (selectq current-processor-type
    (:lambda (LAM-DISK-XFER-VIA-NUBUS SMD-WRITE-COMMAND DISK-BLOCK-NUM CORE-PAGE-NUM N-BLOCKS))
    (:explorer
     (cond ((= n-blocks 1)
	    (nupi-write (send *proc* :page-band-unit) disk-block-num core-page-num n-blocks))
	   (t
	    (ferror nil "foo"))))))


;WRITE OUT ALL PAGES WHETHER OR NOT MODIFIED, SINCE WHEN THIS IS
;CALLED THEY OFTEN HAVEN'T GOTTEN TO DISK YET.
;(DEFUN LAM-DISK-WRITE-OUT-CORE (PARTITION-NAME)
; (ferror nil "can't work")
;  (LET ((X (GET-PARTITION-START-AND-SIZE PARTITION-NAME)))
;    (LET ((PARTITION-START (CAR X)) (PARTITION-SIZE (CDR X)))
;      (DO ((PHT-LOC (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-PNTR)))
;                    (+ 2 PHT-LOC))
;	   (PHT-COUNT (// (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))) 2)
;		      (1- PHT-COUNT))
;	   (PHT1)
;	   (PHT2))
;	  ((= 0 PHT-COUNT))
;	(DECLARE (FIXNUM PHT-LOC PHT-COUNT PHT1 PHT2))
;	(AND (NOT (ZEROP (LOGLDB %%PHT1-VALID-BIT
;				  (SETQ PHT1 (PHYS-MEM-READ PHT-LOC)))))	;IF PAGE EXISTS
;	     (NOT (= (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)
;		     %QF-PHT-DUMMY-VIRTUAL-ADDRESS))		;AND ISN'T A DUMMY
;	     (PROGN					;THEN WRITE IT OUT
;	       (SETQ PHT2 (PHYS-MEM-READ (1+ PHT-LOC)))
;	       (OR (< (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1) PARTITION-SIZE)
;		   (ERROR '|Core doesn't fit in the partition; partition has been clobbered.|
;			  (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1) 'FAIL-ACT))
;	       (LAM-DISK-WRITE-QUEUEING
;			      (+ PARTITION-START
;				 (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1))
;			      (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER PHT2)
;			      1)
;	       (OR (= (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1) %PHT-SWAP-STATUS-WIRED)
;		   (PROGN					;IF NOT WIRED, REMOVE FROM CORE AND
;		     (PHYS-MEM-WRITE PHT-LOC
;				     (DPB %QF-PHT-DUMMY-VIRTUAL-ADDRESS ;STORE BACK DUMMY ENTRY
;					  %%QF-PHT1-VIRTUAL-PAGE-NUMBER
;					  (DPB %PHT-SWAP-STATUS-FLUSHABLE
;					       %%PHT1-SWAP-STATUS-CODE
;					       PHT1)))
;		     (PHYS-MEM-WRITE (1+ PHT-LOC)
;			     (LOGDPB 200 ;READ-ONLY
;				     %%PHT2-ACCESS-STATUS-AND-META-BITS PHT2)))))))
;      ;NOW WRITE OUT THE PAGE HASH TABLE AGAIN SINCE IT'S BEEN MODIFIED
;      ;1P AT A TIME SINCE MIGHT BE BIGGER THAN THE MAP OR SOMETHING
;      ((LAMBDA (PHT-FIRST-PAGE PHT-N-PAGES)
;         (DECLARE (FIXNUM PHT-FIRST-PAGE PHT-N-PAGES))
;	 (DO ((DA (+ PARTITION-START PHT-FIRST-PAGE) (1+ DA))
;	      (PG PHT-FIRST-PAGE (1+ PG))
;	      (N PHT-N-PAGES (1- N)))
;	     ((= N 0))
;	   (DECLARE (FIXNUM DA PG N))
;	   (LAM-DISK-WRITE-QUEUEING DA PG 1)))
;       (// (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-PNTR))) 400)
;       (// (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))) 400)))
;  )) ;DONE, NO NEED TO FLUSH QUEUE SINCE NOT USING QUEUEING NOW

;(DEFUN LAM-DISK-READ-IN-CORE (PARTITION-NAME)
; (ferror nil "can't work")
;  (LET ((X (GET-PARTITION-START-AND-SIZE PARTITION-NAME)))
;    (LET ((PARTITION-START (CAR X)))
;      (QF-CLEAR-CACHE T)			;INVALIDATING CONTENTS OF CORE
;      (LAM-DISK-READ-QUEUEING (1+ (CAR X)) 1 1)	;GET SYSTEM-COMMUNICATION-AREA
;      (DO ((PHT-LOC (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-PNTR))))
;	   (PHT-COUNT (// (+ 377 (QF-POINTER
;                                  (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))))
;			  400))
;	   )
;	  NIL
;	(DECLARE (FIXNUM PHT-LOC PHT-COUNT))
;	(DO J 0 (+ J 1) (NOT (< J PHT-COUNT))		;GET PAGE-TABLE-AREA, 1P AT A TIME
;	    (LAM-DISK-READ-QUEUEING
;			  (+ PARTITION-START (// PHT-LOC 400) J)
;			  (+ (// PHT-LOC 400) J)
;			  1)))				;NOW READ IN ALL THE PAGES
;      (DO ((PHT-LOC (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-PNTR)) (+ 2 PHT-LOC))
;	   (PHT-COUNT (// (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-PAGE-TABLE-SIZE))) 2)
;		      (1- PHT-COUNT))
;	   (PHT1) 
;	   (PG))
;	  ((= 0 PHT-COUNT))
;	(DECLARE (FIXNUM PHT-LOC PHT-COUNT PHT1 PG))
;	(AND (NOT (ZEROP (LOGLDB %%PHT1-VALID-BIT (SETQ PHT1 (PHYS-MEM-READ PHT-LOC)))))
;	     (NOT (= (SETQ PG (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1))
;		     %QF-PHT-DUMMY-VIRTUAL-ADDRESS))		;NOT DUMMY
;	     ;; Don't read in the MICRO-CODE-SYMBOL-AREA, it's part of the ucode logically.
;	     (OR (< PG MICRO-CODE-SYMBOL-AREA-START) (NOT (< PG MICRO-CODE-SYMBOL-AREA-END)))
;	     (LAM-DISK-READ-QUEUEING
;			   (+ PARTITION-START PG)
;			   (LOGLDB %%PHT2-PHYSICAL-PAGE-NUMBER (PHYS-MEM-READ (1+ PHT-LOC)))
;			   1)))
;  ))) ;NO NEED TO EMPTY QUEUE SINCE NOT CURRENTLY USING QUEUEING

(DEFCONST LAM-DISK-LOWCORE 10)
(DEFCONST LAM-DISK-HIGHCORE 300)

(DEFUN LAM-DISK-COPY-PARTITION (FROM-PARTITION TO-PARTITION)
 from-partition to-partition
 (ferror nil "can't work")
 (comment
  (LET ((FROM-DESC (GET-PARTITION-START-AND-SIZE FROM-PARTITION))
	(TO-DESC (GET-PARTITION-START-AND-SIZE TO-PARTITION)))
    (LET ((FROM-START (CAR FROM-DESC))
	  (FROM-SIZE (CDR FROM-DESC))
	  (TO-START (CAR TO-DESC))
	  (TO-SIZE (CDR TO-DESC)))
      (COND ((< TO-SIZE FROM-SIZE)
	     (OR (Y-OR-N-P "~A is smaller.  Continue anyway? " TO-PARTITION)
		 (FERROR NIL "~A is smaller than ~A." TO-PARTITION FROM-PARTITION))))
      ;ALL NUMBERS WITHIN THIS DO ARE IN PAGES, NOT WORDS.
      (DO ((LOWCORE LAM-DISK-LOWCORE)    ;DON'T SMASH BOTTOM 2K WITH SYSTEM-COMMUNICATION, ETC.
	   (HIGHCORE LAM-DISK-HIGHCORE)  ;ONLY RELY ON 48K BEING PRESENT 
	   (RELADR 0 (+ RELADR (- HIGHCORE LOWCORE)))) ;THIS IS RELATIVE LOC WITHIN PARTITION
	  ((NOT (< RELADR (MIN FROM-SIZE TO-SIZE))))
	(DECLARE (FIXNUM LOWCORE HIGHCORE MAP-SIZE RELADR COREADD TOGO))
	(LAM-DISK-READ-QUEUEING
			(+ FROM-START RELADR)
			LOWCORE
			(MIN (- FROM-SIZE RELADR) (- HIGHCORE LOWCORE)))
	(LAM-DISK-WRITE-QUEUEING
			(+ TO-START RELADR)
			LOWCORE
			(MIN (- TO-SIZE RELADR) (- HIGHCORE LOWCORE)))
	)))
 ))	;DONE, NO NEED TO EMPTY QUEUE IN THIS VERSION
    
;(DEFUN LAM-DISK-SAVE (PARTITION)
;  (COND	((NUMBERP PARTITION)
;	 (SETQ PARTITION (INTERN (STRING-APPEND "LOD" (+ 60 PARTITION))))))
;  (GET-PARTITION-START-AND-SIZE PARTITION) ;CAUSE AN ERROR IF NOT A KNOWN PARTITION
;  (LAM-DISK-WRITE-OUT-CORE 'PAGE)
;  (LAM-DISK-COPY-PARTITION 'PAGE PARTITION)
;  (LAM-DISK-READ-IN-CORE 'PAGE))

;(DEFUN LAM-DISK-RESTORE NARGS
;  (LET ((PARTITION (AND (= NARGS 1) (ARG 1))))
;    (COND ((NULL PARTITION)
;	   (AND (> NARGS 1) (ERROR '|TOO MANY ARGS - LAM-DISK-RESTORE| NARGS))
;	   (LAM-DISK-INIT)  ;Use pack editor to find out what is current default load
;	   (SETQ PARTITION INITIAL-LOD-NAME))
;	  ((NUMBERP PARTITION)
;	   (SETQ PARTITION (INTERN (STRING-APPEND "LOD" (+ 60 PARTITION))))))
;    (GET-PARTITION-START-AND-SIZE PARTITION) ;CAUSE AN ERROR IF NOT A KNOWN PARTITION
;    (LAM-DISK-COPY-PARTITION PARTITION 'PAGE)
;    (LAM-DISK-READ-IN-CORE 'PAGE)))

(DEFUN LAM-CHECK-PAGE-HASH-TABLE-ACCESSIBILITY ()
  (qf-setup-pht-addr)
  (let ((table-number-entries 
	  (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)))
    (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2))
	 (PHT1)
	 (COUNT table-number-entries (1- COUNT))
	 (NUMBER-ERRORS 0)
	 (virt-adr-mask (logand -400 %qf-pointer-mask))
	 (total-probes 0)
	 (items-looked-up 0)
	 (max-probes 0)
	 (max-virt-adr nil)
	 (dummies 0))
	((= COUNT 0) 
	 (format t "~%Max probes ~s (at ~s), avg probes ~s, items ~s, dummies ~s, table-size ~s"
		 max-probes
		 max-virt-adr
		 (// (+ 0.0 total-probes) items-looked-up)
		 items-looked-up
		 dummies
		 table-number-entries)
	 NUMBER-ERRORS)
      (DECLARE (FIXNUM TABLE-ADR HASH-ADR COUNT))
      (SETQ PHT1 (PHYS-MEM-READ TABLE-ADR))
      (COND ((= 0 (LOGLDB %%PHT1-VALID-BIT PHT1)))
	    ((= %QF-PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)) ;DUMMY
	     (setq dummies (1+ dummies)))
	    (t (multiple-value-bind (hash-adr probes)
		   (QF-PAGE-HASH-TABLE-LOOKUP-WITH-PROBES (LOGAND PHT1 VIRT-ADR-MASK))
		 (if (> probes max-probes)
		     (setq max-probes probes
			   max-virt-adr (LOGAND PHT1 VIRT-ADR-MASK)))
		 (setq total-probes (+ total-probes probes)
		       items-looked-up (1+ items-looked-up))
		 (cond ((NOT (= TABLE-ADR HASH-ADR))
			(format t "
  HASH TABLE PAIR AT PHYS MEM ADR ~s NOT ACCESSIBLE. HASH LOOKUP RETURNS ~S.
	 pht1: ~s pht2: ~s"
				TABLE-ADR HASH-ADR pht1 (phys-mem-read (1+ table-adr)))
			(SETQ NUMBER-ERRORS (1+ NUMBER-ERRORS)) ))))))))

(DEFUN LAM-PRINT-PAGE-HASH-TABLE-WIRED-STATUS ()
  (qf-setup-pht-addr)
  (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2))
       (PHT1)
       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)
	      (1- COUNT)))
      ((= COUNT 0))
   (DECLARE (FIXNUM TABLE-ADR HASH-ADR COUNT))
   (SETQ PHT1 (PHYS-MEM-READ TABLE-ADR))
   (COND ((= 0 (LOGLDB %%PHT1-VALID-BIT PHT1)))
	 ((= %QF-PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1))) ;DUMMY
	 ((= %PHT-SWAP-STATUS-WIRED (LOGLDB %%PHT1-SWAP-STATUS-CODE PHT1))
	  (FORMAT T "~%Table adr ~s: pht1 ~s, pht2 ~s"
		  TABLE-ADR
		  PHT1
		  (PHYS-MEM-READ (1+ TABLE-ADR)))))))

(DEFUN LAM-CHECK-PAGE-HASH-TABLE (&optional physical-pages-of-memory &aux pp-seen-array)
  "check each entry of page hash table is within a valid region"
  (cond ((null physical-pages-of-memory)
	 (setq physical-pages-of-memory 0)
	 (dolist (m (send *proc* :memory-configuration-list))
	   (setq physical-pages-of-memory (+ physical-pages-of-memory (car m))))
	 (format t "~%Physical pages of memory = ~s" physical-pages-of-memory)))
  (setq pp-seen-array (make-array physical-pages-of-memory ':type art-1b))
  (dotimes (c physical-pages-of-memory)
    (cond ((not (zerop (aref pp-seen-array c)))
	   (ferror nil "pp-seen not initialized"))))
  (qf-setup-pht-addr)
  (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2))
       (PHT1)
       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)
	      (1- COUNT))
       (losers-no-region 0)
       (losers-bad-physical-page 0)
       (free-table-slots 0)
       (count-ok 0)
       (dummies-seen 0)
       (swap-status-normal 0)
       (swap-status-flushable 0)
       (swap-status-prepage 0)
       (swap-status-age-trap 0)
       (swap-status-wired 0)
       (rmb (QF-INITIAL-AREA-ORIGIN 'REGION-BITS)))
      ((= COUNT 0)
       (format t "~%~%OK ~S, losers-no-region ~s, losers-bad-physical-page ~s, free pht ~s"
	       count-ok
	       losers-no-region
	       losers-bad-physical-page
	       free-table-slots)
       (format t "~%dummies seen ~s swap status: normal ~s flushable ~s "
	       dummies-seen
	       swap-status-normal
	       swap-status-flushable
	       )
       (format t "~%   prepage ~s age-trap ~s wired ~s"
	       swap-status-prepage
	       swap-status-age-trap
	       swap-status-wired)
       (format t "~%Physical pages not seen: ")
       (dotimes (c physical-pages-of-memory)
	 (cond ((not (= 1 (aref pp-seen-array c)))
		(format t "~5S  " c)))))
   (DECLARE (FIXNUM TABLE-ADR HASH-ADR COUNT))
   (SETQ PHT1 (PHYS-MEM-READ TABLE-ADR))
   (COND ((= 0 (LOGLDB %%PHT1-VALID-BIT PHT1))
	  (setq free-table-slots (1+ free-table-slots)))
	 ((= %QF-PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)) ;DUMMY
	  (let ((pht2 (phys-mem-read (1+ table-adr))))
	    (aset 1 pp-seen-array (ldb %%pht2-physical-page-number pht2))
	    (incf dummies-seen)))
	 (t
	  (let* ((virt-adr (ash (ldb %%QF-pht1-virtual-page-number pht1) 8))
		 (region (qf-region-number-of-pointer virt-adr t))
		 (pht2 (phys-mem-read (1+ table-adr))))
	    (let ((code (ldb %%pht1-swap-status-code  pht1)))
	      (select code
		(%PHT-SWAP-STATUS-NORMAL (incf swap-status-normal))
		(%PHT-SWAP-STATUS-FLUSHABLE (incf swap-status-flushable))
		(%PHT-SWAP-STATUS-PREPAGE (incf swap-status-prepage))
		(%PHT-SWAP-STATUS-AGE-TRAP (incf swap-status-age-trap))
		(%PHT-SWAP-STATUS-WIRED (incf swap-status-wired))
		(t (ferror nil "unknown swap status"))))
	      
	    (cond ((null region)
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, no region"
			   table-adr
			   pht1
			   pht2)
		   (setq losers-no-region (1+ losers-no-region)))
		  ((not (< (ldb %%pht2-physical-page-number pht2)
			   physical-pages-of-memory))
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, physical page too big"
			   table-adr
			   pht1
			   pht2)
		   (setq losers-bad-physical-page (1+ losers-bad-physical-page)))
		  ((not (= 0 (aref pp-seen-array (ldb %%pht2-physical-page-number pht2))))
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, pp seen twice"
			   table-adr
			   pht1
			   pht2))
		  (t (aset 1 pp-seen-array (ldb %%pht2-physical-page-number pht2))
		     (setq count-ok (1+ count-ok))
		     (let ((pht2-meta-bits (ldb %%pht2-meta-bits pht2))
			   (region-meta-bits (ldb %%region-meta-bits
						 (phys-mem-read (+ region rmb)))))
		       ;low two bits are volatility, which can differ.
		       (cond ((not (= (dpb 0 (byte 2 0) ;%%pht2-volatility
					   pht2-meta-bits)
				      (dpb 0 (byte 2 0) region-meta-bits)))
			      (format t "~%Table adr ~s, pht1 ~s, pht2 ~s, 
 meta bits in region table differ from meta bits in PHT and map
map ~s, pht2 ~s, region ~s" table-adr pht1 pht2 pht2-meta-bits region-meta-bits region)
			      (format t "~%  pht-meta-bits: ")
			      (lam-print-meta-bits (ldb %%pht2-access-status-and-meta-bits
							pht2))
			      (format t "~%  region-meta-bits: ")
			      (lam-print-meta-bits (ldb %%region-map-bits
							(phys-mem-read (+ region rmb))))
			      ))))))
	    ))))

(DEFUN LAM-PRINT-PAGE-HASH-TABLE (&optional physical-pages-of-memory
				  &aux pp-seen-array vp-seen-array)
  (cond ((null physical-pages-of-memory)
	 (setq physical-pages-of-memory 0)
	 (dolist (m (send *proc* :memory-configuration-list))
	   (setq physical-pages-of-memory (+ physical-pages-of-memory (car m))))
	 (format t "~%Physical pages of memory = ~s" physical-pages-of-memory)))
  (qf-setup-pht-addr)
  (setq pp-seen-array (make-array physical-pages-of-memory ':type art-1b))
  (setq vp-seen-array (make-array 1_17. ':type art-1b))
  (format t "~&Table-adr  PHT1 PHT2")
  (DO ((TABLE-ADR PHT-ADDR (+ TABLE-ADR 2))
       (PHT1)
       (PHT2)
       (COUNT (LSH (QF-POINTER (PHYS-MEM-READ (+ PAGE-SIZE %SYS-COM-PAGE-TABLE-SIZE))) -1)
	      (1- COUNT))
       (hole-size 0)
       (dummy-run-size 0)
       (count-ok 0)
       (dummy-count 0)
       (RMB (QF-INITIAL-AREA-ORIGIN 'REGION-BITS)))
      ((= COUNT 0)
       (cond ((not (zerop hole-size))
	      (format t "~%HOLES ~d" hole-size)))
       (cond ((not (zerop dummy-run-size))
	      (format t "~%DUMMIES ~d" dummy-run-size)))
       (format t "~%Count OK ~D, Total dummies ~D" count-ok dummy-count)
       )
   (SETQ PHT1 (PHYS-MEM-READ TABLE-ADR))
   (setq pht2 (phys-mem-read (1+ table-adr)))
   (COND ((= 0 (LOGLDB %%PHT1-VALID-BIT PHT1))
	  (setq hole-size (1+ hole-size))
	  (go nodummy))
	 ((= %QF-PHT-DUMMY-VIRTUAL-ADDRESS (LOGLDB %%QF-PHT1-VIRTUAL-PAGE-NUMBER PHT1)) ;DUMMY
	  (setq dummy-count (1+ dummy-count))
	  (aset 1 pp-seen-array (ldb %%pht2-physical-page-number pht2))
	  (setq dummy-run-size (1+ dummy-run-size))
	  (go nohole))
	 (t
	  (format t "~&~6o: ~6o ~6o" table-adr pht1 pht2)
	  (let* ((virt-page (ldb %%QF-pht1-virtual-page-number pht1))
		 (virt-adr (ash virt-page 8))
		 (region (qf-region-number-of-pointer virt-adr t)))
	    (cond ((not (zerop (aref vp-seen-array virt-page)))
		   (format t "~&~6o: ~6o ~6o, virtual page seen twice" table-adr pht1 pht2)))
	    (aset 1 vp-seen-array virt-page)		   
	    (cond ((null region)
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, no region"
			   table-adr
			   pht1
			   pht2))
		  ((not (< (ldb %%pht2-physical-page-number pht2)
			   physical-pages-of-memory))
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, physical page too big"
			   table-adr
			   pht1
			   pht2))
		  ((not (= 0 (aref pp-seen-array (ldb %%pht2-physical-page-number pht2))))
		   (format t "~%Table adr ~s: pht1 ~s, pht2 ~s, pp seen twice"
			   table-adr
			   pht1
			   pht2))
		  (t (aset 1 pp-seen-array (ldb %%pht2-physical-page-number pht2))
		     (setq count-ok (1+ count-ok))
		     (let ((pht2-meta-bits (ldb %%pht2-meta-bits pht2))
			   (region-meta-bits (ldb %%region-meta-bits
						 (phys-mem-read (+ region rmb)))))
		       (cond ((not (= pht2-meta-bits region-meta-bits))
			      (format t "~%Table adr ~s, pht1 ~s, pht2 ~s, 
 meta bits in region table differ from meta bits in PHT and map
map ~s, pht2 ~s, region ~s" table-adr pht1 pht2 pht2-meta-bits region-meta-bits region)
			      (format t "~%  pht-meta-bits: ")
			      (lam-print-meta-bits (ldb %%pht2-access-status-and-meta-bits
							pht2))
			      (format t "~%  region-meta-bits: ")
			      (lam-print-meta-bits (ldb %%region-map-bits
							(phys-mem-read (+ region rmb))))
			      ))))))))
   (cond ((not (zerop hole-size))
	  (format t "~%HOLES ~d" hole-size)
	  (setq hole-size 0)))
 nodummy
   (cond ((not (zerop dummy-run-size))
	  (format t "~%DUMMIES ~d" dummy-run-size)
	  (setq dummy-run-size 0)))
   (go x)
 nohole
   (cond ((not (zerop hole-size))
	  (format t "~%HOLES ~d" hole-size)
	  (setq hole-size 0)))
  X))

(defun lam-check-address-space-map ()
  (LET ((RO  (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
	(RL  (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH))
	(BYTES-PER-WORD (TRUNCATE 32. lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))
	(ENTRY-MASK (1- (LSH 1 lam-%ADDRESS-SPACE-MAP-BYTE-SIZE)))
	(ASM-AREA-NUMBER (FIND-POSITION-IN-LIST 'ADDRESS-SPACE-MAP (QF-INITIAL-AREA-LIST)))
	(number-regions (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-NUMBER-REGIONS)))))
    (LET ((ASM-ORIGIN (QF-POINTER (PHYS-MEM-READ (+ RO ASM-AREA-NUMBER))))
	  (ASM-LENGTH (QF-POINTER (PHYS-MEM-READ (+ RL ASM-AREA-NUMBER))))
	  (SHIFT-PER-ENTRY (MINUS (TRUNCATE 32. BYTES-PER-WORD)))
	  (VIRT-ADR 0))
      (DOTIMES (REL-ADR ASM-LENGTH)
	(LET ((WD (PHYS-MEM-READ (+ REL-ADR ASM-ORIGIN))))
	  (DOTIMES (B BYTES-PER-WORD)
	    (LET* ((R (LOGAND ENTRY-MASK WD))
		   (THAT-RO (QF-POINTER (PHYS-MEM-READ (+ RO R))))
		   (THAT-RL (QF-POINTER (PHYS-MEM-READ (+ RL R)))))
	      (COND ((ZEROP R))
		    ((NOT (AND (>= VIRT-ADR THAT-RO)
			       (< VIRT-ADR (+ THAT-RO THAT-RL))))
		     (FORMAT T "~%ADR MAP ENTRY VIRTUAL ADDRESS ~S SAYS REGION ~S, BUT THAT REGION STARTS AT ~S AND IS ~S LONG"
			     VIRT-ADR R THAT-RO THAT-RL))))
	    (SETQ WD (ASH WD SHIFT-PER-ENTRY)
		  VIRT-ADR (+ VIRT-ADR %ADDRESS-SPACE-QUANTUM-SIZE)))))
      (format t "~%Checking of a.s.m. entries completed, now checking regions vs a.s.m.")
      (let ((first-interesting-region
	      (FIND-POSITION-IN-LIST 'init-list-area (QF-INITIAL-AREA-LIST)))
	    (free-area-bitmap (lam-make-free-area-bitmap)))
	(dotimes (r number-regions)			;%sys-com-number-regions
	  (cond ((lam-region-active-p r free-area-bitmap)
		 (let* ((r-ro (qf-pointer (phys-mem-read (+ ro r))))
			(r-rl (qf-pointer (phys-mem-read (+ rl r))))
			(r-ro-in-pages (// r-ro si:page-size)))
		   (if (>= r first-interesting-region)	;avoid random printouts for low (small) areas.
		       (do ((relp 0 (1+ relp)))
			   ((>= (* relp si:page-size) r-rl))
			 (let ((asm-e (lam-ref-address-space-map (+ r-ro-in-pages relp))))
			   (cond ((not (= r asm-e))
				  (format t "~%Page ~s of region ~s has incorrect A.S.M entry ~s"
					  relp
					  r
					  asm-e)))))))))))
      )))

(defun lam-region-active-p (r &optional free-area-bitmap)
  (LET (;(A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
	(A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
	;(A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
        ;(A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))

	(R-LT  (QF-INITIAL-AREA-ORIGIN 'REGION-LIST-THREAD)))
    (if (null free-area-bitmap)
	(setq free-area-bitmap (lam-make-free-area-bitmap)))
    (DO-NAMED TOP
	      ((AREA 0 (1+ AREA)))
       ((= AREA (1- number-of-areas))
	nil)
      (if (zerop (aref free-area-bitmap area))
	  (DO ((RN (LOGLDB %%QF-POINTER (QF-MEM-READ (+ A-RL AREA)))
		   (LOGLDB %%QF-POINTER (QF-MEM-READ (+ R-LT RN)))))
	      ((LDB-TEST %%QF-BOXED-SIGN-BIT RN)
	       (COND ((NOT (= AREA (LOGAND RN 777777)))
		      (format t "Region thread not linked back to AREA for area ~s!!" area))))
	    (if (= r rn)
		(return-from top area)))))))

(defun lam-make-free-area-bitmap ()
  (let ((array (make-array number-of-areas :type :art-1b))
	(A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
	(f-an  (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-FREE-AREA#-LIST)))))
    (do ((free-area f-an (logldb %%qf-pointer (qf-mem-read (+ a-rl free-area)))))
	((zerop free-area)
	 (return array))
      (aset 1 array free-area))))

(defun lam-print-free-area-list ()
  (LET (;(A-N (QF-INITIAL-AREA-ORIGIN 'AREA-NAME))
	(A-RL (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-LIST))
	;(A-RS (QF-INITIAL-AREA-ORIGIN 'AREA-REGION-SIZE))
        ;(A-MS (QF-INITIAL-AREA-ORIGIN 'AREA-MAXIMUM-SIZE))

	(F-AN  (QF-POINTER (PHYS-MEM-READ (+ 400 %SYS-COM-FREE-AREA#-LIST)))))
    (do ((free-area f-an (logldb %%qf-pointer (qf-mem-read (+ a-rl free-area)))))
	((zerop free-area))
      (format t "~%Area ~D. free" free-area))))

;address space map has one entry per quantum (64. now) pages.
; note: these values can be pretty random for pages below INIT-LIST-AREA
(defun lam-ref-address-space-map (p)
  (let* ((asm-divisor (// %address-space-quantum-size si:page-size))
	 (quantum (// p asm-divisor))
	 (BYTES-PER-WORD (TRUNCATE 32. lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))
	 (WORD (PHYS-MEM-READ (+ (QF-INITIAL-AREA-ORIGIN 'ADDRESS-SPACE-MAP)
				 (TRUNCATE QUANTUM BYTES-PER-WORD)))))
    (LOGAND (1- (LSH 1 lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))
	    (ASH WORD (- (* (\ QUANTUM BYTES-PER-WORD)
			    lam-%ADDRESS-SPACE-MAP-BYTE-SIZE))))))

(defun lam-check-physical-page-data ()
  (let ((RO  (QF-INITIAL-AREA-ORIGIN 'REGION-ORIGIN))
	(RL  (QF-INITIAL-AREA-ORIGIN 'REGION-LENGTH))
	(ppd-AREA-NUMBER (FIND-POSITION-IN-LIST 'PHYSICAL-PAGE-DATA (QF-INITIAL-AREA-LIST)))
	(pht-area-number (find-position-in-list 'page-table-area (qf-initial-area-list))))
    (let* ((ppd-origin (QF-POINTER (PHYS-MEM-READ (+ RO ppd-AREA-NUMBER))))
	   (ppd-LENGTH (QF-POINTER (PHYS-MEM-READ (+ RL ppd-AREA-NUMBER))))
	   (ppd-valid-length (qf-pointer (lam-symbolic-examine-register
					   'a-v-physical-page-data-valid-length)))
	   ;; (ppd-active-end (qf-pointer (lam-symbolic-examine-register
	   ;;				 'a-v-physical-page-data-end)))
	   (ppd-active-length ppd-valid-length)
	   (pht-origin (qf-pointer (phys-mem-read (+ ro pht-area-number))))
	   (pht-length (qf-pointer (phys-mem-read (+ rl pht-area-number))))
	   (pht-index-limit (lam-symbolic-examine-register 'a-pht-index-limit))
	   )
      (format t "~&pht-index-limit = ~s" pht-index-limit)
      (if (> pht-index-limit pht-length)
	  (format t "~&pht-index-limit (~s) is bigger than pht-length (~s)"
		  pht-index-limit pht-length))
      (if (> ppd-valid-length ppd-length)
	  (format t "~&ppd-valid-length (~s) is bigger than ppd-length (~s)"
		  ppd-valid-length ppd-length))
      (dotimes (rel-adr ppd-active-length)
	(let* ((wd (phys-mem-read (+ rel-adr ppd-origin)))
	       (pht-index (ldb 0020 wd)))
	  (cond ((not (= 177777 pht-index))
		 (cond ((not (< pht-index pht-index-limit))
			(format t
				"~%PHYSICAL-PAGE-DATA ent ~s has out of range" rel-adr))
		       ((not (zerop (logand 1 pht-index)))
			(format t "~%PHYSICAL-PAGE-DATA ent ~s has odd pht-index ~s"
				rel-adr pht-index))
		       (t
			(let ((pht1 (phys-mem-read (+ pht-index pht-origin)))
			      (pht2 (phys-mem-read (1+ (+ pht-index pht-origin)))))
			  (cond ((not (= (ldb %%pht2-physical-page-number pht2)
					 rel-adr))
				 (format t "~%PHYSICAL-PAGE-DATA ent ~s points to PHT ent ~s,
 the physical-page of which does not match.  pht1= ~s, pht2= ~s"
					 rel-adr pht-index pht1 pht2)))))))))))))

(DEFUN GET-PARTITION-START-AND-SIZE (PARTITION-NAME)
  (LAM-DISK-INIT)
  (DO ((I 0 (1+ I)))
      ((NOT (< I N-PARTITIONS))
       (ERROR '|No such partition| PARTITION-NAME))
   (COND ((inhibit-style-warnings (SAMEPNAMEP (ARRAYCALL T PARTITION-NAMES I) PARTITION-NAME))
	  (RETURN (CONS (ARRAYCALL FIXNUM PARTITION-START I)
			(ARRAYCALL FIXNUM PARTITION-SIZE I)))))))

;Called on startup (analogous to the PDUMP function on the 10)
(DEFUN LAM-INITIALIZE-ON-STARTUP ()
  (SETQ LAM-FULL-SAVE-VALID NIL)
  (SETQ LAM-PASSIVE-SAVE-VALID NIL)
  ;(SETQ LAM-DISK-TYPE NIL)
  )

(ADD-INITIALIZATION "LAMBDA" '(LAM-INITIALIZE-ON-STARTUP) '(BEFORE-COLD))


(defun lam-load-new-microcode (partition)
  "after you reassemble the microcode, just run this function to get ready to use it."
  (initialize-disk-control)
  (print-disk-label "lam")
  (format t "Putting new microcode on partition ~A.  " partition)
  (cond ((y-or-n-p "Ok? ")
	 (format t "~%Copying micro code to eagle.")
	 (si:load-lmc-file "lambda-ucode;ulambda.lmc" partition)
	 (format t "~%Setting current micro load.")
	 (lam-set-current-microload partition)
	 (format t "~%Loading symbols.")
	 (lam-load-ucode-symbols "lambda-ucode;ulambda.lmc-sym")
	 (print-disk-label "lam")
	 t)
	(t ())))