From d0168f3da8b77e24ea8eafd9c74da35419a96668 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 Aug 2008 12:55:57 +0200 Subject: [PATCH] improve source loc info in nonlocal exits and backtraces * module/system/il/compile.scm (codegen): The currently-executing instruction is actually the one right before the instruction pointer; so for purposes of assv to find a source location for an ip, put the source after the code, as it was before. * module/system/vm/debug.scm (vm-backtrace): Move more code to frame.scm. * module/system/vm/frame.scm (make-frame-chain): Include all frames, even the bootstrap one. For a reentrant backtrace we'll have boostrap programs anyway. Probably should check for objcode[2] == scm_op_halt, to not show those frames in the trace. (frame-line-number, frame-file): New helpers. (print-frame): Print out the line number too. (frame-call-representation): Code from print-frame-call moved here. (print-frame-chain-as-backtrace): A backtrace printer, yays. (program-name): Check link validity before calling frame-address on it. * module/system/vm/program.scm (source:addr, source:line, source:column) (source:file): New accessors for the elements of program-sources. * module/system/vm/vm.scm (vm:last-ip): New export. (vm-last-frame-chain): Use vm:last-ip in making the frame chain. * src/vm.h (struct scm_vm): * src/vm.c (make_vm, scm_vm_last_ip, scm_vm_save_stack): Save the last instruction pointer when saving the stack. Really though, we should be saving all of the stack data on a spaghetti stack. * src/vm_system.c (late-variable-ref): Pointless s/REGISTER/BEFORE_GC/. --- module/system/il/compile.scm | 4 +- module/system/vm/debug.scm | 6 +-- module/system/vm/frame.scm | 79 ++++++++++++++++++++++++++---------- module/system/vm/program.scm | 10 +++++ module/system/vm/vm.scm | 4 +- src/vm.c | 12 ++++++ src/vm.h | 1 + src/vm_system.c | 4 +- 8 files changed, 88 insertions(+), 32 deletions(-) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 233147e25..14f9f95ab 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -107,8 +107,8 @@ (define (codegen ghil) (let ((stack '())) (define (push-code! loc code) - (if loc (set! stack (cons (make-glil-source loc) stack))) - (set! stack (cons code stack))) + (set! stack (cons code stack)) + (if loc (set! stack (cons (make-glil-source loc) stack)))) (define (push-bindings! loc vars) (if (not (null? vars)) (push-code! diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 4d23d7c54..71b757d11 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -58,7 +58,5 @@ ;;; (define (vm-backtrace vm) - (let ((chain (vm-last-frame-chain vm))) - (if (null? chain) - (display "No backtrace available\n") - (for-each print-frame (reverse! chain))))) + (print-frame-chain-as-backtrace + (reverse! (vm-last-frame-chain vm)))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 464dffd06..ae702356c 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -21,9 +21,10 @@ (define-module (system vm frame) :use-module (system vm program) + :use-module ((srfi srfi-1) :select (fold)) :export (frame-number frame-address make-frame-chain - print-frame print-frame-call + print-frame print-frame-chain-as-backtrace frame-arguments frame-local-variables frame-external-variables frame-environment frame-variable-exists? frame-variable-ref frame-variable-set! @@ -43,11 +44,12 @@ (define (make-frame-chain frame addr) (let* ((link (frame-dynamic-link frame)) - (chain (if (eq? link #t) - '() - (cons frame (make-frame-chain - link (frame-return-address frame)))))) - (set! (frame-number frame) (length chain)) + (chain (cons frame + (if (eq? link #t) + '() + (make-frame-chain + link (frame-return-address frame)))))) + (set! (frame-number frame) (1- (length chain))) (set! (frame-address frame) (- addr (program-base (frame-program frame)))) chain)) @@ -57,30 +59,63 @@ ;;; Pretty printing ;;; -(define (print-frame frame) - (format #t "#~A " (frame-number frame)) - (print-frame-call frame) - (newline)) +(define (frame-line-number frame) + (let ((addr (frame-address frame))) + (cond ((assv-ref (program-sources (frame-program frame)) addr) + => source:line) + (else (format #f "@~a" addr))))) -(define (print-frame-call frame) +(define (frame-file frame prev) + (let ((sources (program-sources (frame-program frame)))) + (if (null? sources) + prev + (or (source:file (car sources)) + "current input")))) + +(define (print-frame frame) + (format #t "~4@a: ~a ~a\n" (frame-line-number frame) (frame-number frame) + (frame-call-representation frame))) + + +(define (frame-call-representation frame) (define (abbrev x) - (cond ((list? x) (if (> (length x) 3) - (list (abbrev (car x)) (abbrev (cadr x)) '...) - (map abbrev x))) - ((pair? x) (cons (abbrev (car x)) (abbrev (cdr x)))) - ((vector? x) (case (vector-length x) - ((0) x) - ((1) (vector (abbrev (vector-ref x 0)))) - (else (vector (abbrev (vector-ref x 0)) '...)))) + (cond ((list? x) + (if (> (length x) 3) + (list (abbrev (car x)) (abbrev (cadr x)) '...) + (map abbrev x))) + ((pair? x) + (cons (abbrev (car x)) (abbrev (cdr x)))) + ((vector? x) + (case (vector-length x) + ((0) x) + ((1) (vector (abbrev (vector-ref x 0)))) + (else (vector (abbrev (vector-ref x 0)) '...)))) (else x))) - (write (abbrev (cons (program-name frame) - (frame-arguments frame))))) + (abbrev (cons (program-name frame) (frame-arguments frame)))) + +(define (print-frame-chain-as-backtrace frames) + (if (null? frames) + (format #t "No backtrace available.\n") + (begin + (format #t "Backtrace:\n") + (pk frames (map frame-program frames) + (map frame-address frames) + ) + (fold (lambda (frame file) + (let ((new-file (frame-file frame file))) + (if (not (eqv? new-file file)) + (format #t "In ~a:\n" new-file)) + (print-frame frame) + new-file)) + 'no-file + frames)))) (define (program-name frame) (let ((prog (frame-program frame)) (link (frame-dynamic-link frame))) (or (object-property prog 'name) - (frame-object-name link (1- (frame-address link)) prog) + (and (frame? link) + (frame-object-name link (1- (frame-address link)) prog)) (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d)) prog (module-obarray (current-module)))))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index fdd7bd336..a0ccee5f0 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -22,6 +22,7 @@ (define-module (system vm program) :export (arity:nargs arity:nrest arity:nlocs arity:nexts make-binding binding:name binding:extp binding:index + source:addr source:line source:column source:file program-bindings program-sources program-properties program-property program-documentation @@ -47,6 +48,15 @@ (cond ((program-meta prog) => car) (else '()))) +(define (source:addr source) + (car source)) +(define (source:line source) + (vector-ref (cdr source) 0)) +(define (source:column source) + (vector-ref (cdr source) 1)) +(define (source:file source) + (vector-ref (cdr source) 2)) + (define (program-sources prog) (cond ((program-meta prog) => cadr) (else '()))) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index 550700363..b6a47953e 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -23,7 +23,7 @@ :use-module (system vm frame) :use-module (system vm objcode) :export (vm? the-vm make-vm vm-version - vm:ip vm:sp vm:fp + vm:ip vm:sp vm:fp vm:last-ip vm-load vm-return-value @@ -44,7 +44,7 @@ (make-frame-chain (vm-this-frame vm) (vm:ip vm))) (define (vm-last-frame-chain vm) - (make-frame-chain (vm-last-frame vm) (vm:ip vm))) + (make-frame-chain (vm-last-frame vm) (vm:last-ip vm))) (define (vm-fetch-locals vm) (frame-local-variables (vm-this-frame vm))) diff --git a/src/vm.c b/src/vm.c index 3804b5e54..c3fbc944f 100644 --- a/src/vm.c +++ b/src/vm.c @@ -277,6 +277,7 @@ make_vm (void) vp->options = SCM_EOL; vp->this_frame = SCM_BOOL_F; vp->last_frame = SCM_BOOL_F; + vp->last_ip = NULL; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); @@ -540,6 +541,16 @@ SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_last_ip +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip); +} +#undef FUNC_NAME + SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0, (SCM vm), "") @@ -550,6 +561,7 @@ SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0, SCM_VALIDATE_VM (1, vm); vp = SCM_VM_DATA (vm); vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest); + vp->last_ip = vp->ip; return vp->last_frame; } #undef FUNC_NAME diff --git a/src/vm.h b/src/vm.h index ef3022916..d0fe11265 100644 --- a/src/vm.h +++ b/src/vm.h @@ -63,6 +63,7 @@ struct scm_vm { SCM *stack_limit; /* stack limit address */ SCM this_frame; /* currrent frame */ SCM last_frame; /* last frame */ + scm_byte_t *last_ip; /* ip when exception occured */ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ SCM options; /* options */ unsigned long time; /* time spent */ diff --git a/src/vm_system.c b/src/vm_system.c index 0e734d821..c45126f04 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -267,9 +267,9 @@ VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1) if (!SCM_VARIABLEP (pair_or_var)) { - SYNC_BEFORE_GC (); + SYNC_REGISTER (); + /* either one of these calls might longjmp */ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var)); - /* module_lookup might longjmp */ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var)); OBJECT_SET (objnum, pair_or_var); if (!VARIABLE_BOUNDP (pair_or_var))