summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-10-08 12:21:20 +0200
committerAndy Wingo <wingo@pobox.com>2010-10-08 12:31:56 +0200
commitb262b74b51142bbc066438fe034c7c22c000feb0 (patch)
tree6d9a22fe17fdaf29df3e73ef9bd97c9f211bbe6d
parentd608db1d593cf46af4a5fc519dcc7274d422378b (diff)
downloadguile-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.c33
-rw-r--r--libguile/programs.h2
-rw-r--r--module/system/vm/frame.scm15
-rw-r--r--module/system/vm/program.scm59
-rw-r--r--module/system/vm/traps.scm56
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)