[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-213-gb43e81d
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-213-gb43e81d |
Date: |
Thu, 03 Oct 2013 20:48:24 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b43e81dc6085f250a3520b69b6445dbc0896850c
The branch, master has been updated
via b43e81dc6085f250a3520b69b6445dbc0896850c (commit)
via 7c54029740a147a623c1f0564708d5471addf232 (commit)
from d7928d7c61f297dca574e20bb5815253e90b3a36 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b43e81dc6085f250a3520b69b6445dbc0896850c
Author: Andy Wingo <address@hidden>
Date: Thu Oct 3 22:48:17 2013 +0200
anonymous RTl functions print with source info
* module/system/vm/debug.scm (find-program-sources): If there is no
source location before the low-pc of the procedure we're grovelling
for, we were skipping the source loc info. Fix that.
* module/system/vm/program.scm (write-program): Get source info for
anonymous RTL functions.
(program-sources, program-sources-pre-retire): Provide program
counters relative to the beginning of the procedure.
commit 7c54029740a147a623c1f0564708d5471addf232
Author: Andy Wingo <address@hidden>
Date: Thu Oct 3 22:31:37 2013 +0200
program-source / program-sources works with RTL programs
* libguile/programs.c (scm_program_sources): Define as %program-sources,
and let Scheme export the program-sources proper.
(scm_program_source): Call out to Scheme.
* module/system/vm/program.scm: Convert to use match instead of pmatch.
Adapt existing callers.
(program-sources, program-source): New Scheme implementations of these
functions.
(program-sources-pre-retire): Add RTL program case.
-----------------------------------------------------------------------
Summary of changes:
libguile/programs.c | 36 ++++++----------
module/system/vm/debug.scm | 6 ++-
module/system/vm/program.scm | 92 ++++++++++++++++++++++++++++--------------
3 files changed, 79 insertions(+), 55 deletions(-)
diff --git a/libguile/programs.c b/libguile/programs.c
index 37130d0..5039d2a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -297,7 +297,7 @@ SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0,
0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
+SCM_DEFINE (scm_program_sources, "%program-sources", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_sources
@@ -365,32 +365,24 @@ scm_i_program_properties (SCM program)
}
#undef FUNC_NAME
-static SCM
-program_source (SCM program, size_t ip, SCM sources)
+SCM
+scm_program_source (SCM program, SCM ip, SCM sources)
{
- SCM source = SCM_BOOL_F;
+ static SCM program_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))) */
-}
+ if (scm_is_false (program_source)) {
+ if (!scm_module_system_booted_p)
+ return SCM_BOOL_F;
+
+ program_source =
+ scm_c_private_variable ("system vm program", "program-source");
+ }
-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);
if (SCM_UNBNDP (sources))
- sources = scm_program_sources (program);
- return program_source (program, scm_to_size_t (ip), sources);
+ return scm_call_2 (scm_variable_ref (program_source), program, ip);
+ else
+ return scm_call_3 (scm_variable_ref (program_source), program, ip,
sources);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1,
0, 0,
(SCM program),
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 0531188..6142f3d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -506,9 +506,11 @@ section of the ELF image. Returns an ELF symbol, or
@code{#f}."
(line-prog (ctx-die (die-ctx die))))))))
(cond
((and low-pc high-pc prog)
- (line-prog-scan-to-pc prog (1- low-pc))
(let lp ((sources '()))
- (call-with-values (lambda () (line-prog-advance prog))
+ (call-with-values (lambda ()
+ (if (null? sources)
+ (line-prog-scan-to-pc prog low-pc)
+ (line-prog-advance prog)))
(lambda (pc file line col)
(if (and pc (< pc high-pc))
(lp (cons (make-source/dwarf (+ pc base) file line col)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 267e373..fb87d97 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -19,7 +19,7 @@
;;; Code:
(define-module (system vm program)
- #:use-module (system base pmatch)
+ #:use-module (ice-9 match)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
#:use-module (system vm debug)
@@ -119,6 +119,27 @@
;; fixed length
(instruction-length inst))))))
+(define (program-sources proc)
+ (cond
+ ((rtl-program? proc)
+ (map (lambda (source)
+ (cons* (- (source-post-pc source) (rtl-program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (rtl-program-code proc))))
+ (else
+ (%program-sources proc))))
+
+(define* (program-source proc ip #:optional (sources (program-sources proc)))
+ (let lp ((source #f) (sources sources))
+ (match sources
+ (() source)
+ (((and s (pc . _)) . sources)
+ (if (<= pc ip)
+ (lp s sources)
+ source)))))
+
;; 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
@@ -130,25 +151,34 @@
;; 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"))))))))
+ (cond
+ ((rtl-program? proc)
+ (map (lambda (source)
+ (cons* (- (source-pre-pc source) (rtl-program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (rtl-program-code proc))))
+ (else
+ (let ((bv (objcode->bytecode (program-objcode proc))))
+ (let lp ((in (program-sources proc))
+ (out '())
+ (ip 0))
+ (cond
+ ((null? in)
+ (reverse out))
+ (else
+ (match (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))))
+ (_
+ (error "unexpected"))))))))))
(define (collapse-locals locs)
(let lp ((ret '()) (locs locs))
@@ -185,19 +215,19 @@
(else (inner (cdr binds)))))))))
(define (arity:start a)
- (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+ (match a ((start end . _) start) (_ (error "bad arity" a))))
(define (arity:end a)
- (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+ (match a ((start end . _) end) (_ (error "bad arity" a))))
(define (arity:nreq a)
- (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+ (match a ((_ _ nreq . _) nreq) (_ 0)))
(define (arity:nopt a)
- (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+ (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
(define (arity:rest? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+ (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
(define (arity:kw a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+ (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
(define (arity:allow-other-keys? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+ (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
(define (program-arity prog ip)
(let ((arities (program-arities prog)))
@@ -211,15 +241,15 @@
(else (lp (cdr arities))))))))
(define (arglist->arguments-alist arglist)
- (pmatch arglist
- ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ (match arglist
+ ((req opt keyword allow-other-keys? rest . extents)
`((required . ,req)
(optional . ,opt)
(keyword . ,keyword)
(allow-other-keys? . ,allow-other-keys?)
(rest . ,rest)
(extents . ,extents)))
- (else #f)))
+ (_ #f)))
(define* (arity->arguments-alist prog arity
#:optional
@@ -301,7 +331,7 @@
(define (write-program prog port)
(define (program-identity-string)
(or (procedure-name prog)
- (and=> (and (program? prog) (program-source prog 0))
+ (and=> (program-source prog 0)
(lambda (s)
(format #f "~a at ~a:~a:~a"
(number->string (object-address prog) 16)
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-213-gb43e81d,
Andy Wingo <=