1(library (nmosh debugger core) 2 (export debugger) 3 (import (rnrs) (nmosh global-flags) 4 (nmosh debugger condition-printer) 5 (prefix (nmosh ui deco) deco:) 6 (nmosh conditions) 7 (srfi :48) 8 (srfi :98) 9 (primitives 10 dbg-files dbg-syms fasl-read %get-nmosh-dbg-image)) 11 12(define (guru-mode?) 13 (get-global-flag '%nmosh-guru-mode)) 14 15(define color-output? 16 (get-environment-variable "NMOSH_CLICOLOR")) 17 18 19(define libsyms '()) 20 21(define intsyms '()) 22 23(define (list-dbgfile) 24 (map cadr dbg-files)) 25 26(define (get-symfile fn) 27 (guard 28 (c (#t 29 (when (guru-mode?) 30 (display (format "Cannot load ~a\n" fn) (current-error-port))) 31 #f)) 32 (call-with-port (open-file-input-port fn) fasl-read))) 33 34(define (load-symfiles) 35 (define syms '()) 36 (define (addsym l) 37 (set! syms (append syms l))) 38 (define (step fn) 39 (let ((r (get-symfile fn))) 40 (when r 41 (for-each 42 (lambda (e) 43 (if (eq? 'DBG-SYMS (car e)) 44 (addsym (cdr e)))) 45 r)))) 46 (let ((f (list-dbgfile))) 47 (for-each step f)) 48 syms) 49 50(define (load-intsyms) 51 (define syms '()) 52 (define (addsym l) 53 (set! syms (append syms l))) 54 (define (step l) 55 (for-each 56 (lambda (e) 57 (if (eq? 'DBG-SYMS (car e)) 58 (addsym (cdr e)))) 59 l)) 60 (for-each step (%get-nmosh-dbg-image)) 61 syms) 62 63(define (ungensym sym) 64 (define (chopseqnum l) ; => symbol 65 (define (step e cur) 66 (if (char=? #\~ e) 67 '() 68 (cons e cur))) 69 (string->symbol (list->string (fold-right step '() l)))) 70 (let ((l (string->list (symbol->string sym)))) 71 (if (char=? #\& (car l)) 72 (chopseqnum (cdr l)) 73 sym))) 74 75(define (disp l) 76 (display l (current-error-port))) 77 78(define deco/err 79 (if color-output? 80 deco:deco/err 81 disp)) 82 83(define (fallback-trace-printer/deco trace) 84 85 (define (cprocprint h) 86 (let ((proc (car h))) 87 (disp " cprc ") 88 (deco/err proc))) 89 (define (undec proc) 90 (define (do-undec sym) 91 (if (symbol? sym) 92 (ungensym sym) 93 sym)) 94 (deco/err (map do-undec proc))) 95 (define (decprint proc) 96 (define (step cur e) 97 (cond 98 ((assq e libsyms) => (lambda (p) (cons 'lib p))) 99 ((assq e dbg-syms) => (lambda (p) (cons 'dbg p))) 100 ((assq e intsyms) => (lambda (p) (cons 'int p))) 101 (else cur))) 102 (let ((dbg (fold-left step #f proc))) 103 (cond 104 (dbg 105 (case (car dbg) 106 ((lib) (disp "==USRP== ")) 107 ((dbg) (disp "==DBGP== ")) 108 ((int) (disp " nmsh "))) 109 (undec proc) 110 (disp " @ ") 111 (deco/err (debug-format (cddr dbg)))) 112 (else 113 (disp " usrp ") 114 (undec proc))))) 115 (define (procprint h) 116 (let ((proc (car h)) 117 (loc (cadr h))) 118 (cond 119 (loc 120 (disp " mosh ") 121 (deco/err proc) 122 (disp " @ ") 123 (deco/err (debug-format loc))) 124 (else 125 (decprint proc))))) 126 127 (define (numprint i) 128 (when (< i 10) 129 (disp " ")) 130 (when (< i 100) 131 (disp " ")) 132 (deco/err i) 133 (disp " : ")) 134 135 (define (print num e) 136 (let ((id (cadr e)) 137 (param (cddr e))) 138 (case id 139 ((*proc*) 140 (numprint num) 141 (procprint param)) 142 ((*cproc*) 143 (numprint num) 144 (cprocprint param)) 145 (else 'ok))) 146 (disp "\n")) 147 (define (user-code? e) 148 (define (step cur e) 149 (cond 150 ((assq e libsyms) #t) 151 ((assq e dbg-syms) #t) 152 ((assq e intsyms) #f) 153 (else cur))) 154 (define (find-dbginfo-for-user prc) 155 (fold-left step #f prc)) 156 (define (user-proc? h) 157 (let ((loc (cadr h))) 158 (cond 159 (loc #f) ; mosh baselib 160 (else (find-dbginfo-for-user (car h)))))) 161 (let ((id (cadr e)) 162 (param (cddr e))) 163 (case id 164 ((*proc*) 165 (user-proc? param)) 166 ((*cproc*) #f) 167 (else #f)))) 168 (define (printer t) 169 (define (itr i cur) 170 (when (pair? cur) 171 (case (cadar cur) 172 ((*unknown-proc*) 173 (itr i (cdr cur))) 174 (else 175 (print i (car cur)) 176 (itr (+ i 1) (cdr cur)))))) 177 (itr 1 t)) 178 (define (strip t) 179 (define (do-strip cur) 180 (if (pair? cur) 181 (if (user-code? (car cur)) 182 cur 183 (do-strip (cdr cur))) 184 '())) 185 (cond 186 ((guru-mode?) t) 187 (else 188 (do-strip t)))) 189 (let* ((disp-a (reverse (strip trace))) 190 (disp-t (if (pair? disp-a) (cdr disp-a) '()))) 191 (unless (= 0 (length disp-t)) 192 (disp "TRACE!! :\n") 193 (printer disp-t)))) 194 195(define minidebug-key #f) 196 197(define (stacktrace-printer/deco trace) 198 (when (and (pair? trace) (pair? (cdr trace))) 199 (fallback-trace-printer/deco (cdr trace)))) 200 201(define (load-symbols) 202 (set! intsyms (load-intsyms)) 203 (set! libsyms (load-symfiles))) 204 205(define (debugger c trace) 206 (condition-printer/deco c) 207 (when minidebug-key 208 (display "!!! DOUBLE FAULT!\n" (current-error-port)) 209 (exit -1)) 210 (set! minidebug-key #t) 211 (load-symbols) 212 (stacktrace-printer/deco trace) 213 (exit -1)) 214 215) 216