;;; -*- Mode:LISP; Package:K-KBUG; Base:10; Readtable:CL; compile-in-roots:("K-GLOBAL") -*-

;;;; Generic Interface

;;; Functions which can access memory
;;; under either debugger if the machine is 
;;; running or not

(defmacro def-k-generic (name lambda-list kbug-body kbug2-body)
  `(DEFUN ,name ,lambda-list
     (DO () (())
       (BLOCK .TRY.AGAIN.
	 (IF (K-HALTED-P)
	     (RETURN-FROM ,name ,kbug-body)
	   (RETURN-FROM ,name ,kbug2-body))))))

(defmacro kbug-cmd-cerror (cmd &rest params)
  `(WHEN (= -1 (KBUG-CMD ,cmd . ,params))
     (CERROR "Halt Machine"
	     "The machine is running,~@
              but the debugger does not seem to be responding.~@
              Type ~c to halt the machine." #\resume)
     (K-STOP)
     (RETURN-FROM .TRY.AGAIN.)))
     

(def-k-generic kbug-generic-read-memory (addr)
  (k-read-virtual-memory addr)
  ;---------------------------
  (progn (kbug-cmd-cerror k2:kbug-command-read-memory addr 1.)
	 (kbug-data 0)))

(def-k-generic kbug-generic-write-memory (addr data &optional inhibit-read-only)
  (progn (k-write-virtual-memory addr data inhibit-read-only)
	 data)
  ;---------------------------------
  (progn (kbug-set-data 0 data)
         (kbug-cmd-cerror k2:kbug-command-write-memory addr 1.)	;should hack inhibit-read-only?
	 data))


(def-k-generic kbug-generic-read-instruction (doubleword-address)
  (lam:read-inst-physical-with-offset doubleword-address)	;from physical memory offset of *code-start*
  (kbug-read-inst doubleword-address))	;this reads virtual memory and supplies the PC-space bit.


;;;; Generic HW memory functions


(defvar *kbug2-md*)
(defvar *kbug2-vma*)

(def-k-generic hw::read-md ()
  (r-md)
 ;(saving-current-k-pc
 ;  #'(lambda () (r-md)))
  ;----------------------
  *kbug2-md*)


(def-k-generic hw::read-vma ()
  (r-vma)
 ;(saving-current-k-pc
 ;  #'(lambda () (r-vma)))
  ;-----------------------
  *kbug2-vma*)

(def-k-generic hw::vma-start-read-vma-boxed-md-boxed (location)
  (k-read-virtual-memory location)
;  (saving-current-k-pc
;    #'(lambda ()
;	(k-read-virtual-memory location)))
  ;------------------------
  (progn (kbug-cmd-cerror k2:kbug-command-read-memory
			  (setq *kbug2-vma* location) 1.)
	 (setq *kbug2-md* (kbug-data 0))))


(def-k-generic kbug-read-map-cluster (cluster)
  (map::read-map cluster)
  (kbug2-read-map-cluster cluster))

(defun hw::vma-start-read-vma-unboxed-md-boxed (location)
  (hw::vma-start-read-vma-boxed-md-boxed location))

(defun hw::vma-start-read-no-transport (location boxed-vma boxed-md)
  boxed-vma boxed-md
  (hw:vma-start-read-vma-boxed-md-boxed location))


(defun show-memory (addr &optional (how-many 32.))
  (cond ((not (numberp addr))
	 (setq addr (kbug2-get-starting-address addr))))
  (dotimes (i how-many)
    (let ((d (kbug-generic-read-memory (+ addr i))))
      (format t "~&~7,'0x: ~8,'0x  ~c~c~c~c ~40t~7,'0x ~a"
	      (+ addr i) d
	      (ldb (byte 8 0) d)
	      (ldb (byte 8 8) d)
	      (ldb (byte 8 16) d)
	      (ldb (byte 8 24) d)
	      (dpb (ldb (byte 6 20.) d)
		   (byte 6 20.)
		   (ldb (byte 20. 0) d))
	      (k-data-type-name d)))))

(defun show-physical-memory (addr &optional (how-many 32.))
  (cond ((not (numberp addr))
	 (format t "~%Remember, this is physical memory")	;guy is probaby losing.
	 (setq addr (kbug2-get-starting-address addr))))
  (dotimes (i how-many)
    (let ((d (lam:k-mem-read-word-address (+ addr i))))
      (format t "~&~7,'0x: ~8,'0x  ~c~c~c~c ~40t~7,'0x ~a"
	      (+ addr i) d
	      (ldb (byte 8 0) d)
	      (ldb (byte 8 8) d)
	      (ldb (byte 8 16) d)
	      (ldb (byte 8 24) d)
	      (dpb (ldb (byte 6 20.) d)
		   (byte 6 20.)
		   (ldb (byte 20. 0) d))
	      (k-data-type-name d)))))

(defun show-instruction-memory-as-data (pc &optional (how-much #x100))
  (dotimes (i how-much)
    (let ((d0 (k-read-virtual-memory (logior #X2000000 (ash (+ i pc) 1.))))
	  (d1 (k-read-virtual-memory (logior #x2000001 (ash (+ i pc) 1.)))))
      (format t "~&lh:~7,'0x: ~8,'0x  ~c~c~c~c ~40t~7,'0x ~a"
	    (+ pc i) d0
	    (ldb (byte 8 0) d0)
	    (ldb (byte 8 8) d0)
	    (ldb (byte 8 16) d0)
	    (ldb (byte 8 24) d0)
	    (dpb (ldb (byte 6 20.) d0)
		 (byte 6 20.)
		 (ldb (byte 20. 0) d0))
	    (k-data-type-name d0))
      (format t "~&hh:~7,'0x: ~8,'0x  ~c~c~c~c ~40t~7,'0x ~a"
	    (+ pc i) d1
	    (ldb (byte 8 0) d1)
	    (ldb (byte 8 8) d1)
	    (ldb (byte 8 16) d1)
	    (ldb (byte 8 24) d1)
	    (dpb (ldb (byte 6 20.) d1)
		 (byte 6 20.)
		 (ldb (byte 20. 0) d1))
	    (k-data-type-name d1)))))

(defun show-stuff (addr count)
  (do ((i 1 (+ 3 i)))
      ((>= i count))
    (let ((csp (kbug-generic-read-memory (+ addr i 0)))
	  (oar (kbug-generic-read-memory (+ addr i 1)))
	  (type (kbug-generic-read-memory (+ addr i 2))))
      (format t "~&~3d:  o:~2x  a:~2x  r:~2x  ~a"
	      (ldb (byte 8 0) csp)
	      (ldb (byte 8 16) oar)
	      (ldb (byte 8 8) oar)
	      (ldb (byte 8 0) oar)
	      (case (ldb (byte 4 0) type)
		(1 'open-call)
		(2 'open)
		(3 'open-call-topen)
		(t (ldb (byte 4 0) type)))))))

(defun show-current-control-pdl ()
  (let ((cp (read-global-register 'gr:*control-pdl*))
	(cpp (read-global-register 'gr:*control-pdl-pointer*))
	(cpl (read-global-register 'gr:*control-pdl-limit*)))
    (format t "pdl: #x~x    pointer: #x~x    limit: #x~x" cp cpp cpl)
    (when (> (ldb (byte 24 0) cpp) (ldb (byte 24 0) cpl))	;fudge fudge
      (format t "Pointer beyond limit in current control pdl"))
    (show-control-pdl (ldb (byte 24 0) cp)
		      (ceiling (- (ldb (byte 24 0) cpp)
				  (ldb (byte 24 0) cp) 3) 18.))))		      

(defun show-control-pdl (address &optional frame-count)
  (unless (= (ldb (byte 5. 21.) (kbug-generic-read-memory address))
	     28.)				;ART-CONTROL-PDL
    (error nil "not a control-pdl"))
  (let ((stack-group (+ address 2))
	(pointer (kbug-generic-read-memory (+ address 2))))
    (format t "~&Control pdl: #x~x   Stack group: #x~x    pointer: #x~x" address stack-group pointer)
    (do* ((addr (+ address 3) (+ 18 addr))
	  (first-word (kbug-generic-read-memory addr)
		      (kbug-generic-read-memory addr))
	  (pc (kbug-generic-read-memory (1+ addr))
	      (kbug-generic-read-memory (1+ addr)))
	  (box-bits (ldb (byte 16 16) first-word)
		    (ldb (byte 16 16) first-word))
	  (i 0 (1+ i)))
	 ((if frame-count
	      (>= i frame-count)
	    (>= addr (ldb (byte 24 0) pointer))))
      (macrolet ((bit (n) `(ldb (byte 1 ,n) box-bits))
		 (reg (n) `(kbug-generic-read-memory (+ addr 2 ,n))))
	(format t "~&~[Open    ~;OpenCall~;T-Open  ~;P-O-C   ~] ~8x ~4x ~6x ~~@{~^~<~%~1:; ~[ ~;*~]~8,48x~;~>~}~"
		(ldb (byte 2 0) first-word)	;type code
		pc
		(ldb (byte 7 2) first-word)	;return destination
		(ldb (byte 4 9) first-word)	;global frame
		(bit 0)  (reg 0)   (bit 1)  (reg 1)
		(bit 2)  (reg 2)   (bit 3)  (reg 3)
		(bit 4)  (reg 4)   (bit 5)  (reg 5)
		(bit 6)  (reg 6)   (bit 7)  (reg 7)
		(bit 8)  (reg 8)   (bit 9)  (reg 9)
		(bit 10) (reg 10)  (bit 11) (reg 11)
		(bit 12) (reg 12)  (bit 13) (reg 13)
		(bit 14) (reg 14)  (bit 15) (reg 15))))))


(defun k-data-type (pointer)
  (hw:ldb pointer vinc:%%data-type 0))

(defun k-data-type-name (pointer)
  (let* ((type (k-data-type pointer))
	 (type-entry (rassoc type vinc:k-data-type-names-alist :key #'car)))
    (if type-entry
	(car type-entry)
      type)))
      
      
(defun read-string (pointer)
  (if (/= (k-data-type pointer) vinc:$$dtp-array)
      (cerror "OK" "This isn't a string, it is a ~s" (k-data-type pointer))) 
  (let ((header (kbug-generic-read-memory pointer)))
    (if (/= (k-data-type header) vinc:$$dtp-array-header-single)
	(cerror "OK" "This isn't an array header, it's a ~s" (k-data-type header)))
    (let* ((length (hw:ldb header array:%%bounds 0))
	   (string (make-string length)))
      (dotimes (i length)
	(setf (svref string i)
	      (int-char (hw:ldb (kbug-generic-read-memory (+ pointer (ash i -2) 1))
				(byte 8 (* 8 (ldb (byte 2 0) i)))
				0))))
      string)))
	

(defun kbug-local-symbol (pointer)
  (if (/= (hw:ldb pointer vinc:%%data-type 0)
	  vinc:$$dtp-symbol)
      (global:ferror "This isn't a symbol, it is a ~s" (k-data-type pointer)))
  (let ((header (kbug-generic-read-memory pointer)))
    (if (/= (hw:ldb header vinc:%%data-type 0)
	    vinc:$$dtp-symbol-header)
	(global:ferror "This symbol's header is clobbered, it's a ~s" (k-data-type header)))
    (intern (read-string (hw:dpb vinc:$$dtp-array vinc:%%data-type header)) *package*)))

(defun read-symbol-name (pointer &optional (expect-symbol-datatype t))
  (if (and expect-symbol-datatype
	   (/= (hw:ldb pointer vinc:%%data-type 0)
	       vinc:$$dtp-symbol))
      (cerror "OK" "This isn't a symbol, it is a ~s" (k-data-type pointer)))
  (let ((header (kbug-generic-read-memory pointer)))
    (if (/= (hw:ldb header vinc:%%data-type 0)
	    vinc:$$dtp-symbol-header)
	(cerror "OK" "This isn't a symbol header, it's a ~s" (k-data-type header)))
    (read-string (hw:dpb vinc:$$dtp-array vinc:%%data-type header))))

(defun local-corresponding-symbol (pointer)
  (if (/= (hw:ldb pointer vinc:%%data-type 0)
	  vinc:$$dtp-symbol)
      (cerror "OK" "This isn't a symbol, it is a ~s" (k-data-type pointer)))
  (let ((header (kbug-generic-read-memory pointer)))
    (if (/= (hw:ldb header vinc:%%data-type 0)
	    vinc:$$dtp-symbol-header)
	(cerror "OK" "This isn't a symbol header, it's a ~s" (k-data-type header)))
    (let* ((symbol-pname-string (read-string (hw:dpb vinc:$$dtp-array vinc:%%data-type header)))
	   (package-cell (kbug-generic-read-memory (+ pointer symbol:*symbol-package*)))
	   (package-cell-datatype (ldb vinc:%%data-type package-cell)))
      (cond ((not (= package-cell-datatype vinc:$$dtp-structure))
	     (global:fsignal "Unable to decode package cell contents"))
	    (t (let ((possible-structure-symbol  (kbug-generic-read-memory (1+ package-cell))))
		 (cond ((or (not (= (ldb vinc:%%data-type possible-structure-symbol)
				    vinc:$$dtp-symbol))
			    (not (string-equal (read-symbol-name possible-structure-symbol)
					       "PACKAGE")))
			(global:fsignal "Bad structure in package cell"))
		       (t (let ((package-name-component
				  (kbug-generic-read-memory (+ package-cell 2))))
			    (show-object package-name-component)
			    (global:fsignal "foo")))))))
      ;for now, just return the string
      symbol-pname-string
      )))
      
(defun show-symbol (pointer &optional (stream t) (expect-symbol-datatype t) (print-package nil))
  (zl:condition-case (.error.)
      (format stream "~a" (read-symbol-name pointer expect-symbol-datatype))
   (zl:error (format stream "Can't print pointer #x~X: ~A" pointer .error.))))

(defun show-string (pointer)
  (print (read-string pointer)))

(defun show-list (pointer)
  (do ()
      ((zerop pointer))
    (format t "~&~x" (kbug-generic-read-memory pointer))
    (setq pointer (kbug-generic-read-memory (1+ pointer)))))

(defun show-compiled-function (pointer &optional (stream t))
  (format stream "#'~a" (read-symbol-name (kbug-generic-read-memory (1+ pointer)))))

(defun show-structure (pointer &optional (stream t))
  ;below lossage necessary until named structures get fixed.
  (let ((possible-structure-symbol  (kbug-generic-read-memory (1+ pointer))))
    (global:select (ldb vinc:%%data-type possible-structure-symbol)
      (vinc:$$dtp-symbol
	   ;assume it is
	(format stream "#S(~a ...)" (read-symbol-name possible-structure-symbol)))
      (vinc:$$dtp-array
	(show-array pointer stream))
      (t (format stream "Unable to decode #x~X as structure" pointer)))))

(defun show-array (pointer &optional (stream t))
  (let* ((header (kbug-generic-read-memory pointer))
	 (acode (ldb array:%%sv-art header))
	 (bounds (ldb array:%%bounds header)))
    (format stream "~%Array acode:~s bounds ~s" acode bounds)))

(defvar *show-object-max-depth* 3)
(defvar *show-object-max-length* 5)

(defun show-data-type-and-object (pointer &optional (stream t))
  (format t "~19a" (k-data-type-symbol (ldb vinc:%%data-type pointer)))
  (show-object pointer stream))

(defun show-object (pointer &optional (stream t) (current-length 0) (current-depth 0))
  (cond ((>= current-depth *show-object-max-depth*)
	 (format stream " ### "))
	((>= current-length *show-object-max-length*)
	 (format stream " ... "))
	(t 
	 (global:select (ldb vinc:%%data-type pointer)
	   (vinc:$$dtp-nil (format stream "NIL"))
	   (vinc:$$dtp-fixnum (format stream "#x~x"
				      (cond ((zerop (ldb vinc:%%fixnum-sign-bit pointer))
					     (ldb vinc:%%fixnum-field pointer))
					    (t
					     (global:minus (1+ (logxor #o37777777 (logand #o37777777 pointer))))))))
	   (vinc:$$dtp-bignum       (show-bignum pointer stream))
	   (vinc:$$dtp-short-float  (show-short-float pointer stream))
	   (vinc:$$dtp-single-float (show-single-float pointer stream))
	   (vinc:$$dtp-double-float (show-double-float pointer stream))
	   (vinc:$$dtp-symbol (show-symbol pointer stream))
	   (vinc:$$dtp-compiled-function (show-compiled-function pointer stream))
	   (vinc:$$dtp-array (format stream "~s" (read-string pointer)))
	   (vinc:$$dtp-structure (show-structure pointer stream))
	   (vinc:$$dtp-code
	     (format stream "~A" (get-warm-symbolic-address pointer)))
	   (vinc:$$dtp-unbound
	     (format stream "Unbound: ")
	     (show-symbol pointer stream nil))
	   (vinc:$$dtp-cons (show-cons pointer stream current-length current-depth))
	   (t (format stream "~%Datatype is ~s, hex:  " (ldb vinc:%%data-type pointer))
	      (hex32 pointer stream))))))

(defun show-bignum (pointer stream)
  (let* ((size (zl:ldb (byte 19. 0) (kbug-generic-read-memory pointer)))
	 (high-word (kbug-generic-read-memory (+ pointer size))))
    (cond ((zerop (ldb vinc:%%bignum-sign-high-word high-word))
	   (format stream "= #x~8,'0x " high-word)
	   (do ((n (1- size) (1- n)))
	       ((zerop n))
	     (format stream "~8,'0x " (kbug-generic-read-memory (+ pointer n)))))
	  (t (let ((non-zero-word (do ((n 1 (1+ n)))
				      ((plusp (kbug-generic-read-memory (+ pointer n))) n))))
	       (format stream "= #x-")
	       (do ((n size (1- n)))
		   ((= n non-zero-word))
		 (format stream "~8,'0x" (logxor #xFFFFFFFF (kbug-generic-read-memory (+ pointer n)))))
	       (do ((n non-zero-word (1- n)))
		   ((zerop n))
		 (format stream "~8,'0x" (logand #xFFFFFFFF (1+ (logxor #xFFFFFFFF
									(kbug-generic-read-memory (+ pointer n))))))))))))
  
(defun show-short-float (pointer stream)
  (let* ((sign-bit  (nlisp:ldb hw#:%%short-float-sign pointer))
	 (sign-char (if (zerop sign-bit) '+ '-))
	 (sign      (if (zerop sign-bit) 1 -1))
	 (exp-actu  (nlisp:ldb hw#:%%short-float-exponent pointer))
	 (exp       (- exp-actu hw#:$$short-float-exponent-excess))
	 (scale-exp (- exp (prims#:byte-size hw#:%%short-float-mantissa)))
	 (mant      (nlisp:ldb hw#:%%short-float-mantissa pointer)))
    (cond ((zerop exp-actu)
	   (format stream " = ~s0.0s0" sign-char))
	  ((= 255 exp-actu)
	   (format stream "Short Float Not a Number."))
	  (t
	   (format stream "~s1.~17,'0b*2^~d = ~d" sign-char mant exp
		   (* sign (+ mant (expt 2 (prims#:byte-size hw#:%%short-float-mantissa))) (expt 2 scale-exp)))))))

(defun show-single-float (pointer stream)
  (show-single (kbug-generic-read-memory pointer) stream))

(defun show-single (single stream)
  (let* ((sign-bit  (nlisp:ldb hw#:%%single-float-sign single))
	 (sign-char (if (zerop sign-bit) '+ '-))
	 (sign      (if (zerop sign-bit) 1 -1))
	 (exp-actu  (nlisp:ldb hw#:%%single-float-exponent single))
	 (exp       (- exp-actu hw#:$$single-float-exponent-excess))
	 (scale-exp (- exp (prims#:byte-size hw#:%%single-float-mantissa)))
	 (mant      (nlisp:ldb hw#:%%single-float-mantissa single)))
    (cond ((zerop exp-actu)
	   (format stream "~s0.~23,'0b*2^~d = ~d" sign-char mant exp (* sign mant (expt 2 scale-exp))))
	  ((= 255 exp-actu)
	   (format stream "Single Float Not a Number."))
	  (t
	   (format stream "~s1.~17,'0b*2^~d = ~d" sign-char mant exp
		   (* sign (+ mant (expt 2 (prims#:byte-size hw#:%%single-float-mantissa))) (expt 2 scale-exp)))))))

(defun show-double-float (pointer stream)
  (declare (ignore pointer))
  (format stream "Show Double not yet done."))

(defun show-cons (pointer stream current-length current-depth)
  (let ((car (kbug-generic-read-memory pointer))
	(cdr (kbug-generic-read-memory (1+ pointer))))
    (format stream "(")
    (show-object car stream 0 (1+ current-depth))
    (cond ((= (ldb vinc:%%data-type cdr) vinc:$$dtp-cons)
	   (format stream " ")
	   (show-list-tail cdr stream (1+ current-length) current-depth))
	  (t
	   (format stream " . ")
	   (show-object cdr stream (1+ current-length) current-depth)))
    (format stream ")")))

(defun show-list-tail (pointer stream current-length current-depth)
  (cond ((>= current-length *show-object-max-length*)
	 (format stream " ... "))
	(t
	 (let ((car (kbug-generic-read-memory pointer))
	       (cdr (kbug-generic-read-memory (1+ pointer))))
	   (show-object car stream 0 (1+ current-depth))
	   (cond ((= (ldb vinc:%%data-type cdr) vinc:$$dtp-cons)
		  (format stream " ")
		  (show-list-tail cdr stream (1+ current-length) current-depth))
		 (t
		  (format stream " . ")
		  (show-object cdr stream (1+ current-length) current-depth)))))))
  

(defun read-symbol-value (symbol)
  (kbug-generic-read-memory
    (+ symbol:*symbol-value*
       (kbug-intern (symbol-name symbol) (si:package-primary-name (symbol-package symbol))))))

(defun show-symbol-value (symbol)
  (show-object (read-symbol-value symbol)))
    
(defun describe-symbol (symbol &optional package-string)
  (if (null package-string)
      (setq package-string (si:package-primary-name (symbol-package symbol))))
  (let ((symbol-location (kbug-intern (symbol-name symbol) package-string)))
    (format t "~%Description of Symbol ~s in package ~a:" symbol package-string)
    (format t "~%Value cell: ")
    (show-object (kbug-generic-read-memory (+ symbol:*symbol-value* symbol-location)))
    (format t "~%Function cell: ")
    (show-object (kbug-generic-read-memory (+ symbol:*symbol-function* symbol-location)))
    (format t "~%Package cell: ")
    (show-object (kbug-generic-read-memory (+ symbol:*symbol-package* symbol-location)))
    (format t "~%Plist cell: ")
    (show-object (kbug-generic-read-memory (+ symbol:*symbol-plist* symbol-location)))))

(defun show-frame-without-datatypes (frame) "This function is decommited, was just show-frame"
  (do ((r 0 (1+ r))
       (rlist (kbug-generic-read-frame-as-list frame) (cdr rlist)))
      ((= r 16.))
    (format t "~% ~2d   ~:[ ~;*~]~8,'0X" r (caar rlist) (cdar rlist))))

(defun show-frame (frame &optional (stream t))
  (show-frame-with-datatypes frame stream))

(defun show-all-frames (&optional (stream t))
  (dotimes (n (length *global-frame-table*))
    (show-frame-with-datatypes n stream)))

(defun show-frame-with-datatypes (frame &optional (stream t))
  (let ((frame-register-list (cdr (nth frame *global-frame-table*))))
    (flet ((show-datatypes (frame-reg-list rlist reg stream)
		(if frame-register-list
		    (show-register-with-datatypes frame-reg-list rlist reg stream)
		  (show-rlist-with-datatypes rlist reg stream))))
      (do ((r 0 (1+ r))
	   (rlist (kbug-generic-read-frame-as-list frame) (cdr rlist)))
	  ((= r 16.))
	(format stream "~%")
	(show-datatypes frame-register-list rlist r stream)))))

(defun show-register-with-datatypes (frame-register-list rlist reg stream)
  (let* ((boxed (caar rlist))
	 (pointer (cdar rlist))
	 (dt (ldb vinc:%%data-type pointer))
	 (sym-dt (k-data-type-symbol dt)))
    (cond ((null boxed)
	   (format stream "~12,,a ~2,,2d  ~8,'0X," (nth reg frame-register-list) reg
		   pointer))
	  (t
	   (format stream "~12,,a ~2,,2d *~8,'0X, ~a " (nth reg frame-register-list) reg
		   pointer sym-dt)
	   (show-object pointer stream)))))

(defun show-rlist-with-datatypes (rlist reg stream)
  (let* ((boxed (caar rlist))
	 (pointer (cdar rlist))
	 (dt (ldb vinc:%%data-type pointer))
	 (sym-dt (k-data-type-symbol dt)))
    (cond ((null boxed)
	   (format stream " ~2,,2d  ~8,'0X," reg pointer))
	  (t
	   (format stream " ~2,,2d *~8,'0X, ~a " reg pointer sym-dt)
	   (show-object pointer stream)))))

;CONVENTION:  KBG-xxx are low level routines for when machine is completely stopped.
;   they generally cause loss of inner processor state.
  
  
(defun kbg-read-reg (reg &optional check-oar)
 "Register read for when machine is stopped.  Totally mungs state. Uses OAR path."
  (let ((frame (ldb (byte 8. 4.) reg))
	(offset (ldb (byte 4 0) reg)))
    (saving-oar
      #'(lambda (ignore)
	  (lam:k-write-oar (dpb frame k-hw:%%ch-oar-open 0))
	  (if check-oar (let ((oar (lam:k-read-oar)))
			  (if (not (= frame (ldb k-hw:%%ch-oar-open oar)))
			      (global:fsignal "OAR failed to load, is #x~x should be #x~x"
				       (ldb k-hw:%%ch-oar-open oar) frame))))
	  (kbg-read-open offset)))))

(defun kbg-read-reg-via-left (reg &optional check-oar)
 "Register read for when machine is stopped.  Totally mungs state. Uses OAR path. Uses left source."
  (let ((frame (ldb (byte 8. 4.) reg))
	(offset (ldb (byte 4 0) reg)))
    (saving-oar
      #'(lambda (ignore)
	  (lam:k-write-oar (dpb frame k-hw:%%ch-oar-open 0))
	  (if check-oar (let ((oar (lam:k-read-oar)))
			  (if (not (= frame (ldb k-hw:%%ch-oar-open oar)))
			      (global:fsignal "OAR failed to load, is #x~x should be #x~x"
				       (ldb k-hw:%%ch-oar-open oar) frame))))
	  (kbg-read-open-via-left offset)))))

(defun kbg-read-reg-with-boxed (reg)
 "Register read (incl boxed bit) for when machine is stopped.  Uses OAR path."
  (let ((frame (ldb (byte 8. 4.) reg))
	(offset (ldb (byte 4 0) reg)))
    (saving-oar
      #'(lambda (ignore)
	  (lam:k-write-oar (dpb frame k-hw:%%ch-oar-open 0))
	  (cons (= 1 (kbg-read-open-boxed offset)) (kbg-read-open offset))))))

(defun kbg-read-open (offset)
  (lam:k-execute3 lam:KIH-ALU-NOP (dpb offset (byte 4. 25.) lam:KIL-READ-O0))
  (k-read-spy-mmfio))

(defun kbg-read-open-via-left (offset)	;read from open frame via left source.
  (lam:k-execute3 lam:KIH-ALU-NOP (dpb offset (byte 4. 19.) lam:KIL-READL-O0))
  (k-read-spy-mmfio))

(defun kbg-read-active (offset)
  (lam:k-execute3 lam:KIH-ALU-NOP (dpb offset (byte 4. 25.) lam:KIL-READ-A0))
  (k-read-spy-mmfio))

(defun kbg-read-open-boxed (offset)
  (lam:k-execute lam:KIH-ALU-G1FBR		;clobbers global register 1F
		  (dpb offset (byte 4. 25.) lam:KIL-READ-O0))
  (lam:k-execute3 lam:kih-alu-nop lam:kil-read-pstat)
  (ldb (byte 1. 18.) (k-read-spy-mmfio)))

(defun kbg-find-reg-crosstalk (&optional (reg 0) (data nil))   ;uses right stuff.
  (if data (kbg-write-reg-via-reg reg data))
  (dotimes (frame 256.)
    (let* ((other-reg (dpb frame (byte 8 4) reg))
	   (read-data (kbg-read-reg other-reg)))
      (cond ((= data read-data)
	     (format t "~%Data written at ~x found at ~x"  reg other-reg))))))

(defun kbg-read-reg-crosschecking (reg &optional inhibit-printouts)
 "Register read for when machine is stopped.  Totally mungs state.  Uses global register path
  so only wins for frames to #xf"
 (let ((right-data nil) (left-data nil) (right-frame-data nil) (left-frame-data nil))
  (setq right-frame-data (kbg-read-reg reg t))
  (setq left-frame-data (kbg-read-reg-via-left reg t))
  (setq right-data (kbg-read-global-reg reg))
  (setq left-data (kbg-read-global-reg-via-left reg))
  (cond ((and (null inhibit-printouts)
	      (or (not (= left-data right-data))
		  (not (= right-data left-frame-data))
		  (not (= left-frame-data right-frame-data))))
	 (global:format t "~%Paths differ, register #x~x, left-frame #x~x right-frame #x~x left #x~x, right #x~x"
			 reg left-frame-data right-frame-data left-data right-data)))
  right-data))

(defun kbg-read-global-reg (reg)
  (let ((frame (ldb (byte 4. 4.) reg)))
    (lam:k-execute4 (dpb frame (byte 4. 5.) lam:KIH-ALU-NOP)
		    (dpb reg (byte 4. 25.) lam:KIL-READR-G0))
    (lam:k-read-spy-mmfio)))

(defun kbg-read-global-reg-via-left (reg)
  (let ((frame (ldb (byte 4. 4.) reg)))
    (lam:k-execute4 (dpb frame (byte 4. 5.) lam:KIH-ALU-NOP)
		    (dpb reg (byte 4. 19.) lam:KIL-READL-G0))
    (lam:k-read-spy-mmfio)))


(defun kbg-read-reg-boxed-bit-via-reg (reg)
 "Read boxed bit of register. only wins for frames to #xf"
 (let ((frame (ldb (byte 4. 4.) reg)))
  (lam:k-execute (dpb frame (byte 4. 5.) lam:KIH-ALU-G0)
		 (dpb reg (byte 4. 25.) lam:KIL-READR-G0))
  lam:(k-execute3 kih-alu-nop kil-read-pstat)
  (ldb (byte 1 18.) (lam:k-read-spy-mmfio))))

  
(defun kbg-read-reg-with-boxed-crosschecking (reg)
  (let ((data (kbg-read-reg-crosschecking reg))
	(boxed (kbg-read-reg-boxed-bit-via-reg reg)))
    (cons (= 1 boxed) data)))
				     
(defun kbg-write-reg (reg data &optional (boxed-bit 0))
  "Register write for when machine is stopped. Totally mungs state. Uses OAR path."
  (let ((frame (ldb (byte 8. 4.) reg))
	(offset (ldb (byte 4 0) reg)))
    (saving-oar
      #'(lambda (ignore)
	  (lam:k-write-oar (dpb frame hw:%%ch-oar-open 0))
	  (kbg-write-open offset data boxed-bit)))))

(defun kbg-write-open (offset data boxed-bit)
  (setq boxed-bit (+ boxed-bit 2))	;make boxed code 2 or 3
  (lam:k-execute (dpb boxed-bit (byte 2 (- 54. 32.))
		      (dpb offset (byte 4 (- 41. 32.)) lam:kih-load-o0))
		 data)
  lam:(k-execute3 KIH-NOP 0))
  
(defun kbg-write-reg-via-reg (reg data)
 "Register write for when machine is stopped.  Totally mungs state. Uses global register path
  so only wins for frames to #xf"
 (let ((frame (ldb (byte 4. 4.) reg)))
  ;   lam:(k-execute3 KIH-JUMP #x100)   ;presumably not necessary
   (lam:k-execute (dpb reg (byte 4. 9.) (dpb frame (byte 4. 5) lam:KIH-LOAD-G0)) data)
   lam:(k-execute3 KIH-NOP 0)))



(defun kbg-read-frame-as-list (frame)
  (do* ((r 15. (1- r))
	(rlist))
       ((minusp r) rlist)
    (setq rlist (cons (kbg-read-reg-with-boxed (dpb frame (byte 8 4) r)) rlist))))

(defun kbg-read-all-frames-crosschecking ()
  (dotimes (f 16.)
    (kbg-read-frame-as-list-crosschecking f)))

(defun kbg-read-frame-as-list-crosschecking (frame)
  "Uses register path, max frame #xF"
  (do* ((r 15. (1- r))
	(rlist))
       ((minusp r) rlist)
    (setq rlist (cons (kbg-read-reg-with-boxed-crosschecking (dpb frame (byte 8 4) r)) rlist))))


(def-k-generic kbug-generic-read-register-with-boxed (reg)
  (kbg-read-reg-with-boxed reg)
  (let ((frame (ldb (byte 8 4) reg))
	(offset (ldb (byte 4 0) reg)))
    (nth offset (read-frame-as-list frame))))

(def-k-generic kbug-generic-read-frame-as-list (frame)
  (kbg-read-frame-as-list frame)
  (read-frame-as-list frame))

(defun kbg-read-call-stack-as-list ()
  (let ((saved-pc (lam:k-read-spy-pc))
	(saved-hp-csp (lam:k-read-hp-sp))
	(saved-oar (lam:k-read-oar)))
    (do ((depth (ldb (byte 8 0) saved-hp-csp) (1- depth))
	 (ans (list (list saved-pc (kbg-convert-oar saved-oar)))))	;top level status, sort of valid, maybe.
	((zerop depth)
	 (lam:k-write-hp-csp saved-hp-csp)	;restore csp first.
	 (lam:k-write-oar saved-oar)
	 (lam:k-set-pc saved-pc)
	 (reverse ans))
      (k-write-hp-csp (dpb depth (byte 8. 0.) 0.))
      (let ((retpc-rdest (k-read-retpc-rdest)))
  ;return first.  The toplevel OAR goes with the PC, which we tried to save above.
	(lam:k-execute lam:KIH-RETURN 0.)		;to cause OAR to restore from stack.
	(let ((oar (k-read-oar)))
	  (push (list retpc-rdest (kbg-convert-oar oar)) ans))))))

(defun kbg-read-frame-free-list ()
  (let ((saved-pc (lam:k-read-spy-pc))
	(saved-hp-csp (lam:k-read-hp-sp))
	(saved-oar (lam:k-read-oar)))
    (do ((ans))
	((not (= (global:tyi) #\space ))
	 (lam:k-write-hp-csp saved-hp-csp)	;restore csp first.
	 (lam:k-write-oar saved-oar)
	 (lam:k-set-pc saved-pc)
	 (reverse ans)
	 )
      (lam:k-execute lam:kih-topen #x100)
      (let ((oar (k-read-oar))
	    (hp-csp (lam:k-read-hp-sp)))
	(push (ldb (byte 8 16.) oar) ans)
	(format t "frame:~X hp:~X" (ldb (byte 8 16.) oar) (ldb (byte 8 8) hp-csp))))))

;for some losing reason, the KBUG2 thing (in K2) repacks things.  So simulate that.
(defun kbg-convert-oar (oar)
  (let ((o (ldb (byte 8 16.) oar))
	(a (ldb (byte 8 8) oar)))
    (dpb o (byte 8 8) a)))

(def-k-generic kbug-generic-read-call-stack-as-list ()
  (kbg-read-call-stack-as-list)
  (read-call-stack-as-list))


(defun show-globals (&optional (stream t))	;call update-globals-from-remote-machine before this.
  (do ((ft *global-frame-table* (cdr ft))
       (fn 0 (1+ fn)))
      ((null ft))
    (do ((rn 0 (1+ rn))
	 (gl (cdr (car ft)) (cdr gl)))
	((null gl))
      (multiple-value-bind (contents boxed)
	  (read-register fn rn)
	(format stream "~%~a  " (car gl))
	(let ((special-printer (get (car gl) 'kbug-printer)))
	  (cond (special-printer (funcall special-printer stream contents boxed))
		(boxed (show-object contents stream))
		(t (format stream "Unboxed. #x=~x, #D=~d, #O=~o" contents contents contents))))))))

(defun (:property gr:*save-trap* kbug-printer) (stream contents boxed)
  (if boxed (format t "~%Trap register is #x~x, and boxed!!" contents)
    (k-print-trap-bits stream contents)))

(defun (:property gr:*trap-mask* kbug-printer) (stream contents boxed)
  (if boxed (format t "~%Trap mask is #x~x, and boxed!!" contents)
    (k-print-trap-bits stream contents)))

(defun k-print-trap-bits (stream trap-word)
  (format stream " ~o, bits: " trap-word)
  (lam:print-bits trap-word)
  (do ((bit-no 31. (1- bit-no))
       (p '(reset trace icache-parity icache-nubus-err
		  icache-nubus-timeout icache-page-fault proc-mread-parity proc-mread-nubus-err
		  proc-mread-nubus-timeout proc-mread-page-fault proc-mread-transporter proc-mwrite-nubus-err
		  proc-mwrite-nubus-timeout proc-mwrite-page-fault proc-mwrite-gc floating-point
		  heap-empty instruction-bit datatype overflow
		  spare11 interrupt7 interrupt6 interrupt5
		  interrupt4 interrupt3 interrupt2 interrupt1
		  interrupt0 timer-1024 timer-16384 spurious) (cdr p)))
      ((null p))
    (if (global:bit-test (ash 1 bit-no) trap-word)
	(format stream " ~A " (car p)))))

(defun update-globals-from-remote-machine ()
  "This function has been replaced by UPDATE-GLOBALS"
  "This function has been replaced by UPDATE-GLOBALS")

(defun update-globals ()
  (labels ((update-frame (framelist count)
	     (when framelist
	       (update-globals-internal (cdr (car framelist)) count 0)
	       (update-frame (cdr framelist) (1+ count))))
	   (update-globals-internal (globals frame count)
	     (when globals
	       (let ((this-global (first globals)))
		 (multiple-value-bind (contents boxed) (read-register frame count)
		   (let ((decoded-value
			   (if boxed
			       (let ((datatype (ldb vinc::%%data-type contents)))
				 (cond ((= datatype vinc:$$dtp-fixnum)
					(+ (* (- (expt 2. 24.)) (ldb vinc::%%fixnum-sign-bit contents))
					   (ldb (byte (1- (byte-position vinc::%%fixnum-sign-bit))
						      0)
						contents)))
				       ((= datatype vinc:$$dtp-nil) nil)
				       ((= datatype vinc:$$dtp-code) 'code-pointer)
				       ((= datatype vinc:$$dtp-symbol)
					(cond ((= (logand contents #x3FFFFFF)	;pointer field
						  5.)
					       'T)
					      ((string-equal (read-symbol-name contents)
							     "KEYWORD-GARBAGE")
						;package structure of this doesnt seem well formed.
					       'keyword-garbage)
					      (t
					       (local-corresponding-symbol contents))))
				       (t (format t "~%Found something weird in ~s." this-global)
					  `(weird-thing ,contents))))
			     (progn (format t "~%~s is unboxed." this-global)
				    contents))))
		     (set this-global decoded-value)
		     (update-globals-internal (rest globals) frame (1+ count))))))))
    (update-frame *global-frame-table* 0)))

(defun kbg-read-register (frame offset)		;reads it via OAR. Actually reads right physical memory.
 "Register read for when machine is stopped.  Totally mungs state. Uses OAR path."
    (saving-oar
      #'(lambda (ignore)
	  (lam:k-write-oar (dpb frame hw:%%ch-oar-open 0))
	  (values (kbg-read-open offset)
		  (= 1 (kbg-read-open-boxed offset))))))

(def-k-generic read-register (frame offset)
  (kbg-read-register frame offset)
  (kbug2-read-register frame offset))


(def-k-generic read-transporter-ram (address)
  (kbg-read-transporter-ram address)
  (kbug2-read-transporter-ram address))

(defun kbug2-read-transporter-ram (address)
  (kbug-cmd-confirm k2:kbug-command-read-misc 2 address)
  (let ((response (kbug-data 0))) 
    (cond ((not (numberp response))
	   (global:fsignal "bad reponse" response))
	  ((not (= (ldb vinc:%%data-type response) vinc:$$dtp-fixnum))
	   (global:fsignal "response not fixnum" response)))
    (logand #xf response)))

(def-k-generic write-transporter-ram (address data)
  (kbg-write-transporter-ram address data)
  (kbug2-write-transporter-ram address data))

(defun kbug2-write-transporter-ram (address data)
  (kbug-cmd-confirm k2:kbug-command-write-misc 2 address data)
  data)

(def-k-generic read-gc-ram (address)
  (k-read-gc-ram address)
  (kbug2-read-gc-ram address))

(defun kbug2-read-gc-ram (address)
  (kbug-cmd-confirm k2:kbug-command-read-misc 3 address)
  (let ((response (kbug-data 0))) 
    (cond ((not (numberp response))
	   (global:fsignal "bad reponse" response))
	  ((not (= (ldb vinc:%%data-type response) vinc:$$dtp-fixnum))
	   (global:fsignal "response not fixnum" response)))
    (logand #xf response)))

(def-k-generic write-gc-ram (address data)
  (k-write-gc-ram address data)
  (kbug2-write-gc-ram address data))

(defun kbug2-write-gc-ram (address data)
  (kbug-cmd-confirm k2:kbug-command-write-misc 3 address data)
  data)

;;;;;;;;;;;;;;
;;; Area data
;;;;;;;;;;;;;;

(defun show-all-areas (&optional (stream t))
  (format stream "~2%All areas:")
  (dotimes (area memory-management::*number-of-areas*)
    (let* ((area-data (area-data::area-region-data area))
	   (status    (area-data::area-data-status area-data)))
      (cond ((= status area-data::$$area-free)
	     (do ((first-area area)
		  (a0 (1+ area) (1+ a0)))
		 ((or (= a0 memory-management::*number-of-areas*)
		      (not (= (area-data::area-data-status
				(area-data::area-region-data a0))
			      area-data::$$area-free)))
		  (format stream "~%Areas ~D up to ~D free." first-area a0))
	       (incf area)))
	    (t (show-area area stream))))))
  

;use (update-globals-from-remote-machine) before calling this.
(defun show-area (area stream)
  (format stream "~2%Area ~3d.  " area)
  (let* ((area-data (area-data::area-region-data area))
	 (status    (area-data::area-data-status area-data))
	 (thread    (area-data::area-data-region-thread area-data)))
    (format stream "~[FREE~;Allocated (no regions)~;Allocated~;Fixed~]" status)
    (unless (area-data::area-free? area-data)
      (let ((area-bits (area-data::area-region-bits area)))
	(format stream "~%New regions are Volatility ~d, ~d quant~:*~[a~;um~:;a~] in size."
		(ldb area-data::%%area-region-bits-volatility area-bits)
		(logand #x03FFFFFF (area-data::area-region-size area)))
	(format stream "~%Default-region-bits: ")
	(decode-region-bits (ldb area-data::%%area-region-bits-the-bits area-bits) stream)))
    (when (area-data::area-has-regions? area-data)
	(labels ((show-regions-in-area (region)
		   (show-region region stream)
		   (let* ((thread (area-data::region-list-thread region))
			  (next   (logand thread #x03FFFFFF))
			  (flag   (ldb area-data::%%region-list-thread-end-flag thread)))
		     (cond ((= flag area-data::$$thread-ends)
			    (when (not (= next area))
			      (format stream "~%THREAD DOESN'T LINK ~d ~d!!" area next)))
			   ((= next region)
			    (format stream "~%Infinite loop in thread at region ~d" region))
			   (t
			    (show-regions-in-area next))))))
	  (show-regions-in-area thread)))))

;terminology summary

;  pointer: (data)  			(byte 26. 0)
;  cluster: (granularity of map)	(byte 16. 10.)		64K clusters total.		
;     %%unmapped-vma-byte (unmapped vma low bits)  (byte 10. 0)
;  quantum: (granularity of GC ram)	(byte 12. 14.)		4096 quantums total.
;   region-size must be a multiple of a quantum, therefore max regions = 4096.
;   thus, there are 2**4 = 16. clusters in a quantum.


;important stuff to be able to print on lambda:

;memory data
;   area data	*number-of-areas* = 256.
;     area-region-data
;     area-region-bits
;     area-region-size
;     area-data-status
;     area-data-region-thread
;   region data  all allocated based on max possible 4096. regions.
;     region-bits	(origin: cluster 8.)
;     unsafe-region-free-pointer
;     region-list-thread
;     region-end
;     region-gc-pointer

;   quantum-map  one Q per virtual quantum.  4096 total.
;        at *quantum-map-physical-location*  (cluster 4)
;     %%quantum-map-dqin          (byte 12.  0.)	;Any device can map all quanta
;	where room for this quantum allocated on the paging device.
;     %%quantum-map-device        (byte  4. 12.)	;Up to 16 I/O or paging devices
;     %%quantum-map-region-origin (byte 12. 16.)        ;Same as region number
;     %%quantum-map-status        (byte  2. 28.)
;     %%quantum-map-valid-bit     (byte  1. 28.)
;     %%quantum-map-mapped-bit    (byte  1. 29.)
;     unused (byte 2. 30.)

;   pcd-table one Q per physical cluster.  size *physical-memory-max-clusters*=8192.
;    located in quantum 1, bottom half, ie 8 clusters.
;     unused                      (byte  7.  0.)
;     %%pcd-read-mar-bit          (byte  1.  7.)
;; This field subsumes the next three fields for the purpose of fast dispatching
;; on write faults.
;     %%pcd-write-bits            (byte  3.  8.)
;     %%pcd-write-mar-bit         (byte  1.  8.)
;     %%pcd-read-only-bit         (byte  1.  9.)
;     %%pcd-clean-bit             (byte  1. 10.)
;     %%pcd-virtual-cluster-number (byte (byte-size vinc:%%cluster-number) 11.)
;     unused                      (byte  2. 27.)
;     %%pcd-status                (byte  3. 29.)

;from BOOT (package BOOT:)
;   *initial-physical-cluster-data-physical-location* (30000 octal) 12288.
;commented out *initial-gc-ram-data-physical-location*  (cluster->address 13.)	;1 cluster
;commented out *initial-transporter-ram-data-physical-location*   14.
;;; Virtual addresses of nifty things.
;;; Quantum 0.
;;; Cluster 1.
;   *temporary-map-entry-location*   (lisp::expt 2 (byte-position vinc::%%cluster-number))
;;; Quantum 1.
;;; Clusters 0. 7.
;   *physical-cluster-table-location* (lisp::* 1 (lisp::expt 2.
;							(byte-position vinc::%%quantum-number)))
;;; Clusters 8. 11.
;   *quantum-map-virtual-location*    (+ *physical-cluster-table-location*
;					  (lisp::expt 2.
;						   (1- (byte-position vinc::%%quantum-number))))
;;; Clusters 12. 15.
;   *region-bits-virtual-location*    (+ *quantum-map-virtual-location*
;					  (lisp::expt 2.
;					    (- (byte-position vinc::%%quantum-number) 2)))

;from KOLD-LOADER (package K-COLD:)
;commented out *initial-map-data-physical-location*    (cluster->address 2.)	;64 clusters
;   *quantum-map-physical-location*       4.
;   *quantum-map-clusters*                4.
;   *region-bits-physical-location*       8.
;   *region-bits-clusters*                4.
;   *initial-physical-cluster-data-physical-location* (cluster->address 12.) ;1 cluster
;	 =12288.(30000)
;   *initial-gc-ram-data-physical-location*  (cluster->address 13.) ;1 cluster =13312.(32000)
;   *initial-transporter-ram-data-physical-location*  14.
;;; Virtual addresses of nifty things.
;;; Quantum 0.
;;; Cluster 1.
;   *temporary-map-entry-location*            (ash 1. (byte-position vinc::%%cluster-number))
;;; Quantum 1.
;;; Clusters 0. 7.
;   *physical-cluster-table-location*     (* 1 (ash 1 (byte-position vinc::%%quantum-number)))
;;; Clusters 8. 11.
;   *quantum-map-virtual-location*        (+ *physical-cluster-table-location*
;					   (ash 1. (1- (byte-position vinc::%%quantum-number))))
;;; Clusters 12. 15.
;   *region-bits-virtual-location*   (+ *quantum-map-virtual-location*
;					  (ash 1 (- (byte-position vinc::%%quantum-number) 2)))


;processor data
;   map
;   gc-ram
;   datatype-ram


;boot-vector
;  Intention is whatever boots writes this.  Currently written by pseudo-boot.
;  this would have been read in by prom from disk.  -- also, we are using this to
;  hold a bit of info generated before setq of special-variable can win.

;from KBUG-GENERIC  boot::**boot-vector-origin** is 42.  =#x2A			    observed value 6/20/88
;  boot::**bootprom-version**  (0)						#x2A	#x0
;  boot::**initial-code-physical-location-bv-offset** (1)  *cold-data-size*	#x2B	#x3C00
;  boot::**initial-code-size-in-clusters-bv-offset** (2)			#x2C	#x39
;	      (1+ (ldb vinc::%%cluster-number (ash *cold-code-pointer* 2)))
;  boot::**initial-code-entry-point-bv-offset** (3)				#x2D	#x327B
;      (nc::ncompiled-function-starting-address (find-named-function initial-function))	normally boot:cold-boot-function
;  boot::**physical-memory-block-map** (4.)  Megabyte-per-bit bit-map.		#x2E    #xFF
;-- end "hard" defined locations, begin "soft" --  Intention was, I think, that hard wired would
;    be depended on by the BOOT PROM.
;  boot::*initial-gc-ram-data-physical-location* (5)				#x2F	#x3400
;	      *initial-gc-ram-data-physical-location*
;  boot::*initial-transporter-ram-data-physical-location* (6)			#x30	#x3800
;	      (cluster->address *initial-transporter-ram-data-physical-location*)
;  boot::*cold-load-flag* (7) 1							#x31	#x1
;  boot::*bv-lowlevel-root-region*	these written by MAP-IN-DEBUG-AND-COMMUNCIATION-ROOTS
;  boot::*bv-debug-root-cluster*
;  boot::*bv-communication-root-cluster*

;(trap) function located at location 0
;(non-modifying-exit)  at location 12.
;(modifying-exit) at location 20.
;(diagnostic-trap-exit) at location 28.
;(trap-vector-table) at location 32.  dispatch table at 32. - 63.

;instructions start at PC address #x100.
;(logior #x02000000 (ash PC 1)) converts PC address to data address.

;kbug-base-addr #x800	from kbug2;common-definitions.
;  k-side in kbug2;k2  lambda-side in kbug2;streams.
; 000     - command
; 001     - status
; 002-009 - command parameters 0-7
; 00A-0EF - internal debug storage
; 0F0-0F4 - K output stream
; 0F5-0F9 - K input fasl stream
; 0FA-0FE - K input character stream (one word per character though)
;   0FF   - unused
; 100-1FF - data transfer area
; 200-3FF - stream buffers

;Access physical memory on the K board:
;  (lam:k-mem-read-word-address <board-physical-address>) (lam:k-mem-write-word-address <b-p-adr> <data>) 
;Access virtual memory:
;  (kbug-generic-read-memory <adr>) (kbug-generic-write-memory <adr> <data>)
;    these work in one of two ways:  If the machine is stopped, instructions
;    are mungded in to the processor and clocked.  This will result in loss of
;    processor state.  If the machine is running, it is assumed the "wedge" is
;    running and it is passed a command.

;low physical and virtual memory usage summary:
;		     <physical>       <virtual>
; quantum 0	lisp-structured
;   cluster 0 #x0    NIL and T, boot-vector #x2A(42.) thru #x31.   self-mapped
;   cluster 1 #x400  boot:*temporary-map-entry-location*  also vmem:*temporary-map-entry*
;		used as scratch map location, very temporary.  see vmem:associate-temporary.
;   cluster 2 #x800  kbug communication area			   self-mapped
;   cluster 3 #xc00  unused	        nubus-stuff:*k-io-regs-cluster*
;					mapped to nubus F<slot>FFF
;				   see (nubus-stuff:cause-nubus-interrupt n) and (nubus-stuff:acknowledge-nubus-interrupt n)
;   cluster 4 #x1000 v.cluster #x18     nubus-stuff:*bus-access-cluster*  
;      and so on thru virtual cluster #x1f mapped to physical #x2C00 (physical cluster #xB)
;   physical clusters C, D, E unused in great eventuality.
;	during initialization,  C is *initial-physical-cluster-data-physical-location*, length: term by entry for cluster 0.
;				   ea entry: <phys-cluster> <virt-cluster> <map-status> <cluster-count>
;				   manually setup in k-cold:get-initial-physical-cluster-data
;				D is *initial-gc-ram-data-physical-location*  length:4096. entries **too long**
;				   ea entry: GC-RAM contents as fixnum.
;				   manually setup in k-cold:load-boot-gc-ram-data.
;				E is *initial-transporter-ram-data-physical-location*
;				   ea entry 4 bits, packed 8 to a word. length:4096. entries, 512 words.
;				  initialized to zero as part of *cold-data*
;				  modified by k-cold:modify-boot-transporter-ram-data.
;				  initial data comes from k-kbug:*transporter-ram-initial-data*.
;   physical cluster F holds first code page, virtual cluster #x8000.
; quantum 1
;   clusters 0-7  #x4000	*physical-cluster-table-location*
;   clusters 8-B  #x6000      	*quantum-map-virtual-location*
;   clusters C-F  #x7000	*region-bits-virtual-location*

;boot-allocate-physical-clusters allocates via gr:*physical-cluster-free-pointer*.  active only in bootstrapping.
;  callers:  only (!) pcd:create-physical-cluster-data-table 

;new scheme 7/11/88:  we will use the low physical clusters wasted (i.e. left unused) by the current stuff.
;  cluster 1 will be used for debug stuff
;  cluster 3 will be used for MAC-FALCON-LAMBDA communication.
;Note that neither virtual cluster 1 nor 3 is available, the Falcon will be responsible for setting
;  up other virtual clusters and using them, etc.

;stuff to put in cluster 1	*falcon-debug-root-cluster*
;  header area
;    "main" state vector
;
;  IOPB disk stuff if we have that.

;stuff to put in cluster 3      *falcon-communication-root-cluster*
;  ... talk to RWK, etc.

;new low memory allocations:
;  reasons to put things in low memory:
;     communication areas
;       with MAC
;       with "debugger"
;       with lambda disk
;     key pointers to entry points, etc
;       save-processor-image function   (saves all state information held in processor as a vector.)
;       restore-processor-image function (restores it from there)
;	pcd table origin
;	quantum map table origin
;       disk-command-block
;       keyboard comm area
;       mouse comm area
;       network comm area

;ideas for what all to put there:

;  full-saved-machine-image
;  area-name
;  small disk buffer for booting


;saved-machine-image layout:  SAVE-PROCESSOR-IMAGE and RESTORE-PROCESSOR-IMAGE are in K2

;header:

;formatting info:
; -inner processor state.  mostly saved for debugging.
;  
;	processor status
;	memory status
;	trap-register
;	microsecond clock
;	statistics counter
;	nb: trap state is saved as a frame.
; -main state
;   misc registers
;	processor control
;	memory control
;	OAR
;	HP-CSP
;	Q
;	VMA
;	VMA-BOXED
;	MD
;	MD-BOXED
;   call-stack  512.   256x2  (return code, return offset, return pc word)
;		      (return global-frame, saved o, saved a)
;   frames:     4352.  256. frames x 17. words per frame.  (16 registers plus 1 word of boxed-bits)
; -background state    69.25K allow 70K words total.
;	map		    64Kx32 bits 64K words
;	datatype ram	    128Kx1	packed 32 per word, 4K words
;	transporter ram	    4Kx4	packed 8 per word, 512. words
;	gc ram		    4Kx4	packed 8 per word, 512. words
;	free-frame-list	    256x8	256 words