diff options
author | Andy Wingo <wingo@pobox.com> | 2010-10-08 12:21:20 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-10-08 12:31:56 +0200 |
commit | b262b74b51142bbc066438fe034c7c22c000feb0 (patch) | |
tree | 6d9a22fe17fdaf29df3e73ef9bd97c9f211bbe6d | |
parent | d608db1d593cf46af4a5fc519dcc7274d422378b (diff) | |
download | guile-b262b74b51142bbc066438fe034c7c22c000feb0.tar.gz |
add program-sources-pre-retire to core and define frame-next-source
* libguile/programs.h:
* libguile/programs.c (scm_program_source): Add an optional arg, the
sources table to traverse. Defaults to the result of
scm_program_sources.
* module/system/vm/program.scm (program-sources-pre-retire): Move
definition here from (system vm traps), and export.
* module/system/vm/traps.scm: Adapt.
* module/system/vm/frame.scm (frame-next-source): New exported binding,
returns the source line corresponding to the next instruction instead
of the previous instruction.
-rw-r--r-- | libguile/programs.c | 33 | ||||
-rw-r--r-- | libguile/programs.h | 2 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 15 | ||||
-rw-r--r-- | module/system/vm/program.scm | 59 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 56 |
5 files changed, 93 insertions, 72 deletions
diff --git a/libguile/programs.c b/libguile/programs.c index 3a14f65ed..4404f832a 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -267,28 +267,37 @@ scm_i_program_properties (SCM program) } #undef FUNC_NAME -SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0, - (SCM program, SCM ip), +static SCM +program_source (SCM program, size_t ip, SCM sources) +{ + SCM source = SCM_BOOL_F; + + while (!scm_is_null (sources) + && scm_to_size_t (scm_caar (sources)) <= ip) + { + source = scm_car (sources); + sources = scm_cdr (sources); + } + + return source; /* (addr . (filename . (line . column))) */ +} + +SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0, + (SCM program, SCM ip, SCM sources), "") #define FUNC_NAME s_scm_program_source { SCM_VALIDATE_PROGRAM (1, program); - return scm_c_program_source (program, scm_to_size_t (ip)); + if (SCM_UNBNDP (sources)) + sources = scm_program_sources (program); + return program_source (program, scm_to_size_t (ip), sources); } #undef FUNC_NAME extern SCM scm_c_program_source (SCM program, size_t ip) { - SCM sources, source = SCM_BOOL_F; - - for (sources = scm_program_sources (program); - !scm_is_null (sources) - && scm_to_size_t (scm_caar (sources)) <= ip; - sources = scm_cdr (sources)) - source = scm_car (sources); - - return source; /* (addr . (filename . (line . column))) */ + return program_source (program, ip, scm_program_sources (program)); } SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0, diff --git a/libguile/programs.h b/libguile/programs.h index 7f9b6f72d..d0e788e51 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -54,7 +54,7 @@ SCM_API SCM scm_program_base (SCM program); SCM_API SCM scm_program_meta (SCM program); SCM_API SCM scm_program_bindings (SCM program); SCM_API SCM scm_program_sources (SCM program); -SCM_API SCM scm_program_source (SCM program, SCM ip); +SCM_API SCM scm_program_source (SCM program, SCM ip, SCM sources); SCM_API SCM scm_program_arities (SCM program); SCM_API SCM scm_program_objects (SCM program); SCM_API SCM scm_program_module (SCM program); diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 57ae877ff..94619badf 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -26,7 +26,7 @@ #:export (frame-bindings frame-lookup-binding frame-binding-ref frame-binding-set! - frame-source frame-call-representation + frame-source frame-next-source frame-call-representation frame-environment frame-object-binding frame-object-name frame-return-values)) @@ -71,8 +71,17 @@ ;;; (define (frame-source frame) - (program-source (frame-procedure frame) - (frame-instruction-pointer frame))) + (let ((proc (frame-procedure frame))) + (program-source proc + (frame-instruction-pointer frame) + (program-sources proc)))) + +(define (frame-next-source frame) + (let ((proc (frame-procedure frame))) + (program-source proc + (frame-instruction-pointer frame) + (program-sources-pre-retire proc)))) + ;; Basically there are two cases to deal with here: ;; diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index a1e3ea4f0..02d5ec409 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -20,6 +20,9 @@ (define-module (system vm program) #:use-module (system base pmatch) + #:use-module (system vm instruction) + #:use-module (system vm objcode) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (make-program @@ -29,7 +32,7 @@ source:addr source:line source:column source:file source:line-for-user - program-sources program-source + program-sources program-sources-pre-retire program-source program-bindings program-bindings-by-index program-bindings-for-ip program-arities program-arity arity:start arity:end @@ -71,6 +74,60 @@ (define (source:line-for-user source) (1+ (source:line source))) +;; FIXME: pull this definition from elsewhere. +(define *bytecode-header-len* 8) + +;; We could decompile the program to get this, but that seems like a +;; waste. +(define (bytecode-instruction-length bytecode ip) + (let* ((idx (+ ip *bytecode-header-len*)) + (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) + ;; 1+ for the instruction itself. + (1+ (cond + ((eq? inst 'load-program) + (+ (bytevector-u32-native-ref bytecode (+ idx 1)) + (bytevector-u32-native-ref bytecode (+ idx 5)))) + ((< (instruction-length inst) 0) + ;; variable length instruction -- the length is encoded in the + ;; instruction stream. + (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) + (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) + (bytevector-u8-ref bytecode (+ idx 3)))) + (else + ;; fixed length + (instruction-length inst)))))) + +;; Source information could in theory be correlated with the ip of the +;; instruction, or the ip just after the instruction is retired. Guile +;; does the latter, to make backtraces easy -- an error produced while +;; running an opcode always happens after it has retired its arguments. +;; +;; But for breakpoints and such, we need the ip before the instruction +;; is retired -- before it has had a chance to do anything. So here we +;; change from the post-retire addresses given by program-sources to +;; pre-retire addresses. +;; +(define (program-sources-pre-retire proc) + (let ((bv (objcode->bytecode (program-objcode proc)))) + (let lp ((in (program-sources proc)) + (out '()) + (ip 0)) + (cond + ((null? in) + (reverse out)) + (else + (pmatch (car in) + ((,post-ip . ,source) + (let lp2 ((ip ip) + (next ip)) + (if (< next post-ip) + (lp2 next (+ next (bytecode-instruction-length bv next))) + (lp (cdr in) + (acons ip source out) + next)))) + (else + (error "unexpected")))))))) + (define (collapse-locals locs) (let lp ((ret '()) (locs locs)) (if (null? locs) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index 627e6c581..cccd6eac9 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -309,68 +309,14 @@ #:current-frame current-frame #:vm vm #:our-frame? our-frame?))) -;; FIXME: pull this definition from elsewhere. -(define *bytecode-header-len* 8) - ;; FIXME: define this in objcode somehow. We are reffing the first ;; uint32 in the objcode, which is the length of the program (without ;; the meta). (define (program-last-ip prog) (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0)) -;; We could decompile the program to get this, but that seems like a -;; waste. -(define (bytecode-instruction-length bytecode ip) - (let* ((idx (+ ip *bytecode-header-len*)) - (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) - ;; 1+ for the instruction itself. - (1+ (cond - ((eq? inst 'load-program) - (+ (bytevector-u32-native-ref bytecode (+ idx 1)) - (bytevector-u32-native-ref bytecode (+ idx 5)))) - ((< (instruction-length inst) 0) - ;; variable length instruction -- the length is encoded in the - ;; instruction stream. - (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) - (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) - (bytevector-u8-ref bytecode (+ idx 3)))) - (else - ;; fixed length - (instruction-length inst)))))) - -;; Source information could in theory be correlated with the ip of the -;; instruction, or the ip just after the instruction is retired. Guile -;; does the latter, to make backtraces easy -- an error produced while -;; running an opcode always happens after it has retired its arguments. -;; -;; But for breakpoints and such, we need the ip before the instruction -;; is retired -- before it has had a chance to do anything. So here we -;; change from the post-retire addresses given by program-sources to -;; pre-retire addresses. -;; -(define (program-sources-before-retire proc) - (let ((bv (objcode->bytecode (program-objcode proc)))) - (let lp ((in (program-sources proc)) - (out '()) - (ip 0)) - (cond - ((null? in) - (reverse out)) - (else - (pmatch (car in) - ((,post-ip . ,source) - (let lp2 ((ip ip) - (next ip)) - (if (< next post-ip) - (lp2 next (+ next (bytecode-instruction-length bv next))) - (lp (cdr in) - (acons ip source out) - next)))) - (else - (error "unexpected")))))))) - (define (program-sources-by-line proc file) - (let lp ((sources (program-sources-before-retire proc)) + (let lp ((sources (program-sources-pre-retire proc)) (out '())) (if (pair? sources) (lp (cdr sources) |