;;; -*- Mode:LISP; Package: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) (progn (k-write-virtual-memory addr data) data) ;--------------------------------- (progn (kbug-set-data 0 data) (kbug-cmd-cerror k2:kbug-command-write-memory addr 1.) data)) ;;;; Generic HW memory functions (defvar *kbug2-md*) (defvar *kbug2-vma*) (def-k-generic hw::read-md () (saving-current-k-pc #'(lambda () (r-md))) ;---------------------- *kbug2-md*) (def-k-generic hw::read-vma () (saving-current-k-pc #'(lambda () (r-vma))) ;----------------------- *kbug2-vma*) (def-k-generic hw::vma-start-read-vma-boxed-md-boxed (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)))) (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-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 show-symbol (pointer &optional (stream t) (expect-symbol-datatype t)) (format stream "~a" (read-symbol-name pointer expect-symbol-datatype))) (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))) (defun show-object (pointer &optional (stream t)) (global:select (ldb vinc:%%data-type pointer) (vinc:$$dtp-nil (format stream "NIL")) (vinc:$$dtp-fixnum (format stream "~a" (cond ((zerop (ldb vinc:%%fixnum-sign-bit pointer)) (ldb vinc:%%fixnum-field pointer)) (t (global:minus (1+ (logxor #o37777777 (logand #o37777777 pointer)))))))) (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)) (t (format stream "~%Datatype is ~s, hex: " (ldb vinc:%%data-type pointer)) (hex32 pointer stream)))) (defun show-cons (pointer stream) (format stream "(") (show-object (kbug-generic-read-memory pointer) stream) (format stream " . ") (show-object (kbug-generic-read-memory (1+ pointer)) stream) (format stream ")")) (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 (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-with-datatypes (frame &optional (stream t)) (let ((frame-register-list (cdr (nth frame *global-frame-table*)))) (do ((r 0 (1+ r)) (rlist (kbug-generic-read-frame-as-list frame) (cdr rlist))) ((= r 16.)) (let* ((boxed (caar rlist)) (pointer (cdar rlist)) (dt (ldb vinc:%%data-type pointer)) (sym-dt (k-data-type-symbol dt))) (cond ((and frame-register-list (null boxed)) (format stream "~%~30,,a ~2,,2d ~8,'0X," (nth r frame-register-list) r pointer)) (frame-register-list (format stream "~%~30,,a ~2,,2d *~8,'0X, ~a " (nth r frame-register-list) r pointer sym-dt) (show-object pointer stream)) ((null boxed) (format stream "~% ~20,,2d ~8,'0X," r pointer)) (t (format stream "~% ~20,,2d *~8,'0X, ~a " r 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) "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 hw:%%ch-oar-open 0)) (kbg-read-open 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 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-boxed (offset) (lam:k-execute lam:KIH-ALU-nopbr ;was O0 (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-read-reg-via-reg (reg) "Register read 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-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-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-NOPBR) (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-via-reg (reg) (let ((data (kbg-read-reg-via-reg 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-frame-as-list-via-reg (frame) "Uses register path, max frame #xF" (do* ((r 15. (1- r)) (rlist)) ((minusp r) rlist) (setq rlist (cons (kbg-read-reg-with-boxed-via-reg (dpb frame (byte 8 4) r)) rlist)))) (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)) (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)) (if boxed (show-object contents stream) (format stream "Unboxed. #x=~x, #D=~d, #O=~o" contents contents contents)))))) (defun update-globals-from-remote-machine () (labels ((update-frame (framelist count) (if (null framelist) nil (progn (update-globals (cdr (car framelist)) count 0) (update-frame (cdr framelist) (1+ count))))) (update-globals (globals frame count) (if (null globals) nil (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) (if (= (logand contents #x3FFFFFF) ;pointer field 5.) 'T (error "Can't handle symbols yet."))) (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 (rest globals) frame (1+ count)))))))) (update-frame *global-frame-table* 0))) (defun kbg-read-register (frame offset) "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)) ;;;;;;;;;;;;;; ;;; Area data ;;;;;;;;;;;;;; (defun show-area (area stream) (terpri) (format stream "~%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))) (if (= flag area-data::$$thread-ends) (when (not (= next area)) (format stream "~%THREAD DOESN'T LINK ~d ~d!!" area next)) (show-regions-in-area next))))) (show-regions-in-area thread)))))