mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
d608db1d59
commit
b262b74b51
5 changed files with 93 additions and 72 deletions
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue