164 lines
8.2 KiB
Scheme
164 lines
8.2 KiB
Scheme
(use-modules (gdb)) ; import gdb libraries
|
|
|
|
; == Misc libraries ==
|
|
(use-modules (srfi srfi-9)) ; provides define-record-type
|
|
(use-modules (ice-9 string-fun)) ; provides string-replace-substring
|
|
|
|
; Types
|
|
(define btp-u8 (lookup-type "unsigned char"))
|
|
(define btp-u16 (lookup-type "unsigned short"))
|
|
(define btp-u32 (lookup-type "unsigned int"))
|
|
(define btp-u64 (lookup-type "unsigned long long"))
|
|
(define btp-i8 (lookup-type "char"))
|
|
(define btp-i16 (lookup-type "short"))
|
|
(define btp-i32 (lookup-type "int"))
|
|
(define btp-i64 (lookup-type "long long"))
|
|
(define btp-c8 (lookup-type "char"))
|
|
(define btp-mem (type-pointer (lookup-type "void")))
|
|
(define btp-bool btp-u8)
|
|
(define btp-uptr btp-u64)
|
|
|
|
; == Execute wrappers ==
|
|
; Be careful modifying this, other commands depend on it for multiline commands
|
|
(define gdbw-python (lambda (code) (execute (format #f "python ~a" code) #:to-string #t)))
|
|
|
|
(define gdbw-remove-symbol-file (lambda (file) (execute (format #f "remove-symbol-file ~s" file))))
|
|
|
|
(define gdbw-add-symbol-file (lambda* (file #:key (offset '()))
|
|
(define cmd (format #f "add-symbol-file ~s" file))
|
|
(when (number? offset) (set! cmd (string-append cmd (format #f " -o ~a" offset))))
|
|
(execute cmd)))
|
|
|
|
; HACK: gdb doesn't support multiline execute for guile, so we use execute to call python's execute
|
|
(define gdbw-commands (lambda (breakpoints cmds)
|
|
(for-each (lambda (breakpoint)
|
|
(define gdb-breakpoint breakpoint)
|
|
(when (breakpoint? gdb-breakpoint) (set! gdb-breakpoint (breakpoint-number gdb-breakpoint)))
|
|
; HACK: This is a silly hack that abuses an unchecked cast from unsigned numbers to signed ones in the gdb shell, allowing us to bypass the "no negative numbers!" thing
|
|
(when (< gdb-breakpoint 0) (set! gdb-breakpoint (+ 4294967295 (+ 1 gdb-breakpoint))))
|
|
(gdbw-python (format #f "gdb.execute(~s)" (format #f "commands ~a\n~a\nend" gdb-breakpoint (string-join cmds "\n")))))
|
|
breakpoints)))
|
|
|
|
; HACK: gdb doesn't support connection data for guile, so we have to implement it ourself with this incredible hack
|
|
(define-record-type <gdbw-info-connections-result>
|
|
(make-gdbw-info-connections-result current number what description)
|
|
gdbw-info-connections-result?
|
|
(current gdbw-info-connections-result-current)
|
|
(number gdbw-info-connections-result-number)
|
|
(what gdbw-info-connections-result-what)
|
|
(description gdbw-info-connections-result-description))
|
|
(define gdbw-info-connections (lambda () ; TODO: this looks awful, i'm positive there's a better way to do a lot of this, come back when i understand scheme
|
|
(define compact-gdb-table-row (lambda (raw)
|
|
(define crunch (lambda (pos chunks remain)
|
|
(if (< pos (string-length remain))
|
|
(let ((nidx (string-index remain #\space pos)))
|
|
(if (< (+ nidx 1) (string-length remain))
|
|
(if (char=? (string-ref remain (+ nidx 1)) #\space)
|
|
(let ((fidx (string-skip remain #\space nidx)))
|
|
(crunch 0 (append chunks (list (substring remain 0 nidx))) (substring remain fidx)))
|
|
(crunch (+ nidx 1) chunks remain))
|
|
(append chunks (list (substring remain 0 (- (string-length remain) 1))))))
|
|
(append chunks (list (substring remain 0 (- (string-length remain) 1)))))))
|
|
(crunch 0 '() raw)))
|
|
(map (lambda (l) (let ((crow (compact-gdb-table-row l)))
|
|
(make-gdbw-info-connections-result
|
|
(char=? (string-ref (car crow) 0) #\*)
|
|
(string->number (substring (car crow) 2))
|
|
(car (cdr crow))
|
|
(car (cdr (cdr crow))))))
|
|
(list-head (list-tail (string-split (execute "info connections" #:to-string #t) #\newline) 1) 1))))
|
|
|
|
; == Debugging mode stuff ==
|
|
(define DEBUG_MODE_KERNEL 'KERNEL)
|
|
(define DEBUG_MODE_INVALID 'INVALID)
|
|
(define DEBUG_MODE_NONE 'NONE)
|
|
|
|
(define debug-mode DEBUG_MODE_NONE)
|
|
|
|
(define debug-mode-transition (lambda (mode) ; Reconfigure internal state to debug a new target
|
|
; Check for major fuckups
|
|
(when (equal? mode DEBUG_MODE_INVALID) (error "Transitioned into an invalid debug mode, this should never happen!"))
|
|
|
|
; Deinitialize the previous target's debug code
|
|
(cond
|
|
((equal? debug-mode DEBUG_MODE_KERNEL)
|
|
(delete-breakpoint! kernel-debug-table-update-watcher)))
|
|
|
|
; Set the new debug mode
|
|
(set! debug-mode mode)
|
|
|
|
; Initialize the current target's debug code
|
|
(cond
|
|
((equal? debug-mode DEBUG_MODE_KERNEL)
|
|
(register-breakpoint! kernel-debug-table-update-watcher)
|
|
(gdbw-commands (list kernel-debug-table-update-watcher) '("silent" "lwdbg kernel refresh-debug-tables" "continue"))
|
|
(process-kernel-debug-tables)))))
|
|
|
|
; == Code for processing data in kernel debug tables ==
|
|
(define cckernel-binary-location '())
|
|
(define cckernel-binary-offset '())
|
|
(define kernel-binary-location '())
|
|
(define kernel-binary-offset '())
|
|
(define kernel-debug-table-update-watcher (make-breakpoint "*(0x100000)"
|
|
#:type BP_WATCHPOINT
|
|
#:wp-class WP_WRITE
|
|
#:internal #t))
|
|
(define process-kernel-debug-tables (lambda ()
|
|
(define build-dir (value-dereference (value-cast (make-value #x100008) (type-pointer (type-pointer btp-c8)))))
|
|
(when (not (value=? build-dir (make-value 0)))
|
|
(set! build-dir (value->string build-dir))
|
|
(if (value=? (value-dereference (value-cast (make-value #x100010) (type-pointer btp-bool))) 1)
|
|
((lambda () (define new-cckernel-binary-offset (value->integer (value-dereference (value-cast (make-value #x100018) (type-pointer btp-uptr)))))
|
|
(define new-cckernel-binary-location (string-append build-dir "/lcrash/cckernel"))
|
|
(when (not (equal? new-cckernel-binary-offset cckernel-binary-offset))
|
|
(when (not (null? cckernel-binary-location))
|
|
(gdbw-remove-symbol-file cckernel-binary-location)
|
|
(set! cckernel-binary-location '())
|
|
(set! cckernel-binary-offset '()))
|
|
(gdbw-add-symbol-file new-cckernel-binary-location #:offset new-cckernel-binary-offset)
|
|
(set! cckernel-binary-location new-cckernel-binary-location)
|
|
(set! cckernel-binary-offset new-cckernel-binary-offset))))
|
|
(display "TODO: CCKERNEL UNLOADED\n"))
|
|
(if (value=? (value-dereference (value-cast (make-value #x100020) (type-pointer btp-bool))) 1)
|
|
((lambda () (define new-kernel-binary-offset (value->integer (value-dereference (value-cast (make-value #x100028) (type-pointer btp-uptr)))))
|
|
(define new-kernel-binary-location (string-append build-dir "/lcrash/lcrashkern"))
|
|
(when (not (equal? new-kernel-binary-offset kernel-binary-offset))
|
|
(when (not (null? kernel-binary-location))
|
|
(gdbw-remove-symbol-file kernel-binary-location)
|
|
(set! kernel-binary-location '())
|
|
(set! kernel-binary-offset '()))
|
|
(gdbw-add-symbol-file new-kernel-binary-location #:offset new-kernel-binary-offset)
|
|
(set! kernel-binary-location new-kernel-binary-location)
|
|
(set! kernel-binary-offset new-kernel-binary-offset))))
|
|
(display "TODO: KERNEL UNLOADED\n"))
|
|
|
|
; EDIB
|
|
(when (not (null? kernel-binary-location))
|
|
((lambda () (define edip-ptr (value-cast (make-value #x100030) (type-pointer (type-pointer (lookup-type "struct DebugExtendedDebugInformationBlock")))))
|
|
(when (not (value=? (value-cast (value-dereference edip-ptr) btp-mem) (value-cast (make-value 0) btp-mem)))
|
|
((lambda () (define edip (value-dereference (value-dereference edip-ptr)))
|
|
(when (value->bool (value-field edip "Panic"))
|
|
(format #t "!!! KERNEL PANIC !!!\n")
|
|
(format #t "MSG: ~a\n" (let ((error (value-field edip "PanicError")))
|
|
(if (value=? error (make-value 0)) "N/A" (value->string error))))))))))))))
|
|
|
|
; == Command prefixes ==
|
|
(register-command! (make-command "lwdbg" #:prefix? #t))
|
|
(register-command! (make-command "lwdbg internal" #:prefix? #t))
|
|
(register-command! (make-command "lwdbg kernel" #:prefix? #t))
|
|
|
|
; Called by gdb hookpost for target remote
|
|
(register-command! (make-command "lwdbg internal handle-target-remote-post"
|
|
#:invoke (lambda (self arg from-tty)
|
|
(debug-mode-transition
|
|
(let ((target (string-split (gdbw-info-connections-result-what (car (filter gdbw-info-connections-result-current (gdbw-info-connections)))) #\space)))
|
|
(if (string=? (car target) "remote")
|
|
DEBUG_MODE_KERNEL
|
|
DEBUG_MODE_INVALID))))))
|
|
|
|
; Command to forcefully refresh the thing
|
|
(register-command! (make-command "lwdbg kernel refresh-debug-tables"
|
|
#:command-class COMMAND_USER
|
|
#:doc "Refresh the kernel debug tables"
|
|
#:invoke (lambda (self arg from-tty) (process-kernel-debug-tables))))
|