(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))))