[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-14-g9de674e
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-14-g9de674e |
|
Date: |
Thu, 01 May 2014 19:17:37 +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=9de674e6e63ed1576c5b0660ac709f430822dbcf
The branch, master has been updated
via 9de674e6e63ed1576c5b0660ac709f430822dbcf (commit)
via de0233af177806ac96d535bb58f27875fb8c5375 (commit)
from d7a67c3e918acd8ca46dc7792a8ca98b33cb94e8 (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 9de674e6e63ed1576c5b0660ac709f430822dbcf
Author: Andy Wingo <address@hidden>
Date: Thu May 1 21:14:42 2014 +0200
Rewrite boot-9 map to be recursive and pure
* module/ice-9/boot-9.scm (map): Rewrite to be recursive and pure
instead of iterative and effectful. At best this is faster; at worst
it is slower. In any case it resolves continuation-related issues.
* module/srfi/srfi-1.scm (fold): Specialize the two-arg case.
(map): Rewrite to be recursive.
* test-suite/tests/r5rs_pitfall.test (8.3): Update for new expected map
behavior.
commit de0233af177806ac96d535bb58f27875fb8c5375
Author: Andy Wingo <address@hidden>
Date: Thu May 1 14:26:20 2014 +0200
Fix inner and outer stack cuts to match on procedure code
* doc/ref/api-debug.texi (Stack Capture): Update make-stack docs.
* libguile/programs.h:
* libguile/programs.c (scm_program_address_range): New internal
procedure.
* libguile/stacks.c (narrow_stack): Interpret a pair of integers as an
address range. If a cut is a procedure, attempt to resolve it to an
address range.
(scm_make_stack): Update docstring.
* module/system/vm/program.scm (program-address-range): New exported
procedure.
* module/statprof.scm (statprof, gcprof): Use program-address-range to
get the outer-cut, for efficiency.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-debug.texi | 54 +++++++-------
libguile/programs.c | 14 +++-
libguile/programs.h | 4 +-
libguile/stacks.c | 98 ++++++++++++++++++++----
module/ice-9/boot-9.scm | 143 +++++++++++++-----------------------
module/srfi/srfi-1.scm | 72 ++++++++++++-------
module/statprof.scm | 6 +-
module/system/vm/program.scm | 11 +++
test-suite/tests/r5rs_pitfall.test | 4 +-
9 files changed, 237 insertions(+), 169 deletions(-)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 9b0e564..bf25c74 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -88,33 +88,33 @@ evaluation stack is used for creating the stack frames,
otherwise the frames are taken from @var{obj} (which must be
a continuation or a frame object).
address@hidden @dots{} can be any combination of integer, procedure, prompt
-tag and @code{#t} values.
-
-These values specify various ways of cutting away uninteresting
-stack frames from the top and bottom of the stack that
address@hidden returns. They come in pairs like this:
address@hidden(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}
address@hidden @dots{})}.
-
-Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt
-tag, or a procedure. @code{#t} means to cut away all frames up
-to but excluding the first user module frame. An integer means
-to cut away exactly that number of frames. A prompt tag means
-to cut away all frames that are inside a prompt with the given
-tag. A procedure means to cut away all frames up to but
-excluding the application frame whose procedure matches the
-specified one.
-
-Each @var{outer_cut_i} can be an integer, a prompt tag, or a
-procedure. An integer means to cut away that number of frames.
-A prompt tag means to cut away all frames that are outside a
-prompt with the given tag. A procedure means to cut away
-frames down to but excluding the application frame whose
-procedure matches the specified one.
-
-If the @var{outer_cut_i} of the last pair is missing, it is
-taken as 0.
address@hidden @dots{} can be any combination of integer, procedure, address
+range, and prompt tag values.
+
+These values specify various ways of cutting away uninteresting stack
+frames from the top and bottom of the stack that @code{make-stack}
+returns. They come in pairs like this: @code{(@var{inner_cut_1}
address@hidden @var{inner_cut_2} @var{outer_cut_2} @dots{})}.
+
+Each @var{inner_cut_i} can be an integer, a procedure, an address range,
+or a prompt tag. An integer means to cut away exactly that number of
+frames. A procedure means to cut away all frames up to but excluding
+the frame whose procedure matches the specified one. An address range
+is a pair of integers indicating the low and high addresses of a
+procedure's code, and is the same as cutting away to a procedure (though
+with less work). Anything else is interpreted as a prompt tag which
+cuts away all frames that are inside a prompt with the given tag.
+
+Each @var{outer_cut_i} can likewise be an integer, a procedure, an
+address range, or a prompt tag. An integer means to cut away that
+number of frames. A procedure means to cut away frames down to but
+excluding the frame whose procedure matches the specified one. An
+address range is the same, but with the procedure's code specified as an
+address range. Anything else is taken to be a prompt tag, which cuts
+away all frames that are outside a prompt with the given tag.
+
+
+If the @var{outer_cut_i} of the last pair is missing, it is taken as 0.
@end deffn
@deffn {Scheme Syntax} start-stack id exp
diff --git a/libguile/programs.c b/libguile/programs.c
index fae95d0..64c861a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -180,6 +180,18 @@ scm_find_source_for_addr (SCM ip)
return scm_call_1 (scm_variable_ref (source_for_addr), ip);
}
+SCM
+scm_program_address_range (SCM program)
+{
+ static SCM program_address_range = SCM_BOOL_F;
+
+ if (scm_is_false (program_address_range) && scm_module_system_booted_p)
+ program_address_range =
+ scm_c_private_variable ("system vm program", "program-address-range");
+
+ return scm_call_1 (scm_variable_ref (program_address_range), program);
+}
+
SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1,
0, 0,
(SCM program),
"")
diff --git a/libguile/programs.h b/libguile/programs.h
index 096c2c0..d170c1b 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -67,6 +67,8 @@ SCM_INTERNAL SCM scm_i_program_properties (SCM program);
SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip);
+SCM_INTERNAL SCM scm_program_address_range (SCM program);
+
SCM_API SCM scm_program_num_free_variables (SCM program);
SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i);
SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 7531908..a09c3b9 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -113,6 +113,22 @@ static long
narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
SCM inner_cut, SCM outer_cut)
{
+ /* Resolve procedure cuts to address ranges, if possible. If the
+ debug information has been stripped, this might not be
+ possible. */
+ if (scm_is_true (scm_program_p (inner_cut)))
+ {
+ SCM addr_range = scm_program_address_range (inner_cut);
+ if (scm_is_pair (addr_range))
+ inner_cut = addr_range;
+ }
+ if (scm_is_true (scm_program_p (outer_cut)))
+ {
+ SCM addr_range = scm_program_address_range (outer_cut);
+ if (scm_is_pair (addr_range))
+ outer_cut = addr_range;
+ }
+
/* Cut inner part. */
if (scm_is_true (scm_procedure_p (inner_cut)))
{
@@ -126,6 +142,25 @@ narrow_stack (long len, enum scm_vm_frame_kind kind,
struct scm_frame *frame,
break;
}
}
+ else if (scm_is_pair (inner_cut)
+ && scm_is_integer (scm_car (inner_cut))
+ && scm_is_integer (scm_cdr (inner_cut)))
+ {
+ /* Cut until an IP within the given range is found. */
+ scm_t_uintptr low_pc, high_pc, pc;
+
+ low_pc = scm_to_uintptr_t (scm_car (inner_cut));
+ high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
+
+ for (; len ;)
+ {
+ pc = (scm_t_uintptr) frame->ip;
+ len--;
+ scm_c_frame_previous (kind, frame);
+ if (low_pc <= pc && pc < high_pc)
+ break;
+ }
+ }
else if (scm_is_integer (inner_cut))
{
/* Cut specified number of frames. */
@@ -161,6 +196,30 @@ narrow_stack (long len, enum scm_vm_frame_kind kind,
struct scm_frame *frame,
len = new_len;
}
+ else if (scm_is_pair (outer_cut)
+ && scm_is_integer (scm_car (outer_cut))
+ && scm_is_integer (scm_cdr (outer_cut)))
+ {
+ /* Cut until an IP within the given range is found. */
+ scm_t_uintptr low_pc, high_pc, pc;
+ long i, new_len;
+ struct scm_frame tmp;
+
+ low_pc = scm_to_uintptr_t (scm_car (outer_cut));
+ high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
+
+ memcpy (&tmp, frame, sizeof tmp);
+
+ /* Cut until the given procedure is seen. */
+ for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+ {
+ pc = (scm_t_uintptr) tmp.ip;
+ if (low_pc <= pc && pc < high_pc)
+ new_len = i;
+ }
+
+ len = new_len;
+ }
else if (scm_is_integer (outer_cut))
{
/* Cut specified number of frames. */
@@ -217,7 +276,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"a continuation or a frame object).\n"
"\n"
"@var{args} should be a list containing any combination of\n"
- "integer, procedure, prompt tag and @code{#t} values.\n"
+ "integer, procedure, address range, prompt tag and @code{#t}\n"
+ "values.\n"
"\n"
"These values specify various ways of cutting away uninteresting\n"
"stack frames from the top and bottom of the stack that\n"
@@ -225,24 +285,28 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
"@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
"@var{outer_cut_2} @dots{})}.\n"
"\n"
- "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n"
- "tag, or a procedure. @code{#t} means to cut away all frames up\n"
- "to but excluding the first user module frame. An integer means\n"
- "to cut away exactly that number of frames. A prompt tag means\n"
- "to cut away all frames that are inside a prompt with the given\n"
- "tag. A procedure means to cut away all frames up to but\n"
- "excluding the application frame whose procedure matches the\n"
- "specified one.\n"
+ "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
+ "address range, or a prompt tag. An integer means to cut away\n"
+ "exactly that number of frames. A procedure means to cut\n"
+ "away all frames up to but excluding the frame whose procedure\n"
+ "matches the specified one. An address range is a pair of\n"
+ "integers indicating the low and high addresses of a procedure's\n"
+ "code, and is the same as cutting away to a procedure (though\n"
+ "with less work). Anything else is interpreted as a prompt tag\n"
+ "which cuts away all frames that are inside a prompt with the\n"
+ "given tag.\n"
"\n"
- "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
- "procedure. An integer means to cut away that number of frames.\n"
- "A prompt tag means to cut away all frames that are outside a\n"
- "prompt with the given tag. A procedure means to cut away\n"
- "frames down to but excluding the application frame whose\n"
- "procedure matches the specified one.\n"
+ "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
+ "address range, or a prompt tag. An integer means to cut away\n"
+ "that number of frames. A procedure means to cut away frames\n"
+ "down to but excluding the frame whose procedure matches the\n"
+ "specified one. An address range is the same, but with the\n"
+ "procedure's code specified as an address range. Anything else\n"
+ "is taken to be a prompt tag, which cuts away all frames that
are\n"
+ "outside a prompt with the given tag.\n"
"\n"
- "If the @var{outer_cut_i} of the last pair is missing, it is\n"
- "taken as 0.")
+ "If the @var{outer_cut_i} of the last pair is missing, it is\n"
+ "taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
long n;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8bc8e53..7f38c4b 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -239,49 +239,83 @@ file with the given name already exists, the effect is
unspecified."
-;;; Boot versions of `map' and `for-each', enough to get the expander
-;;; running.
+;;; {map and for-each}
;;;
+
(define map
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
(let map1 ((l l))
- (if (null? l)
- '()
- (cons (f (car l)) (map1 (cdr l))))))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list l2) #f))
+
(let map2 ((l1 l1) (l2 l2))
- (if (null? l1)
- '()
+ (if (pair? l1)
(cons (f (car l1) (car l2))
- (map2 (cdr l1) (cdr l2))))))
+ (map2 (cdr l1) (cdr l2)))
+ '())))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
- (if (null? l1)
- '()
+ (let ((len (length l1)))
+ (let mapn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (mapn (cdr rest))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+ (let mapn ((l1 l1) (rest rest))
+ (if (pair? l1)
(cons (apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (mapn (cdr l1) (map cdr rest)))
+ '())))))
+
+(define map-in-order map)
(define for-each
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
(let for-each1 ((l l))
- (if (pair? l)
+ (if (not (null? l))
(begin
(f (car l))
(for-each1 (cdr l))))))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
(let for-each2 ((l1 l1) (l2 l2))
- (if (pair? l1)
+ (if (not (null? l1))
(begin
(f (car l1) (car l2))
(for-each2 (cdr l1) (cdr l2))))))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
+ (let ((len (length l1)))
+ (let for-eachn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (for-eachn (cdr rest))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length:
~S"
+ (list (car rest)) #f)))))
+
+ (let for-eachn ((l1 l1) (rest rest))
(if (pair? l1)
(begin
(apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (for-eachn (cdr l1) (map cdr rest))))))))
+
;; Temporary definition used in the include-from-path expansion;
;; replaced later.
@@ -831,83 +865,6 @@ for key @var{k}, then invoke @var{thunk}."
-;;; The real versions of `map' and `for-each', with cycle detection, and
-;;; that use reverse! instead of recursion in the case of `map'.
-;;;
-(define map
- (case-lambda
- ((f l)
- (unless (list? l)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f))
- (let map1 ((l l) (out '()))
- (if (pair? l)
- (map1 (cdr l) (cons (f (car l)) out))
- (reverse! out))))
-
- ((f l1 l2)
- (unless (= (length l1) (length l2))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list l2) #f))
-
- (let map2 ((l1 l1) (l2 l2) (out '()))
- (if (pair? l1)
- (map2 (cdr l1) (cdr l2) (cons (f (car l1) (car l2)) out))
- (reverse! out))))
-
- ((f l1 . rest)
- (let ((len (length l1)))
- (let mapn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (mapn (cdr rest))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list (car rest)) #f)))))
- (let mapn ((l1 l1) (rest rest) (out '()))
- (if (null? l1)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest)
- (cons (apply f (car l1) (map car rest)) out)))))))
-
-(define map-in-order map)
-
-(define for-each
- (case-lambda
- ((f l)
- (unless (list? l)
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
- (let for-each1 ((l l))
- (unless (null? l)
- (f (car l))
- (for-each1 (cdr l)))))
-
- ((f l1 l2)
- (unless (= (length l1) (length l2))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list l2) #f))
- (let for-each2 ((l1 l1) (l2 l2))
- (unless (null? l1)
- (f (car l1) (car l2))
- (for-each2 (cdr l1) (cdr l2)))))
-
- ((f l1 . rest)
- (let ((len (length l1)))
- (let for-eachn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (for-eachn (cdr rest))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length:
~S"
- (list (car rest)) #f)))))
-
- (let for-eachn ((l1 l1) (rest rest))
- (if (pair? l1)
- (begin
- (apply f (car l1) (map car rest))
- (for-eachn (cdr l1) (map cdr rest))))))))
-
-
-
-
;;;
;;; Extensible exception printing.
;;;
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 5e859d1..0806e73 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -454,21 +454,41 @@ a list of those after."
;;; Fold, unfold & map
-(define (fold kons knil list1 . rest)
- "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+(define fold
+ (case-lambda
+ "Apply PROC to the elements of LIST1 ... LISTN to build a result, and
return
that result. See the manual for details."
- (check-arg procedure? kons fold)
- (if (null? rest)
- (let f ((knil knil) (list1 list1))
- (if (null? list1)
- knil
- (f (kons (car list1) knil) (cdr list1))))
- (let f ((knil knil) (lists (cons list1 rest)))
- (if (any null? lists)
- knil
- (let ((cars (map car lists))
- (cdrs (map cdr lists)))
- (f (apply kons (append! cars (list knil))) cdrs))))))
+ ((kons knil list1)
+ (check-arg procedure? kons fold)
+ (check-arg list? list1 fold)
+ (let fold1 ((knil knil) (list1 list1))
+ (if (pair? list1)
+ (fold1 (kons (car list1) knil) (cdr list1))
+ knil)))
+ ((kons knil list1 list2)
+ (check-arg procedure? kons fold)
+ (let* ((len1 (length+ list1))
+ (len2 (length+ list2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "fold"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list list1 list2)) #f))
+ (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
+ (if (zero? len)
+ knil
+ (fold2 (kons (car list1) (car list2) knil)
+ (cdr list1) (cdr list2) (1- len))))))
+ ((kons knil list1 . rest)
+ (check-arg procedure? kons fold)
+ (let foldn ((knil knil) (lists (cons list1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((cars (map car lists))
+ (cdrs (map cdr lists)))
+ (foldn (apply kons (append! cars (list knil))) cdrs)))))))
(define (fold-right kons knil clist1 . rest)
(check-arg procedure? kons fold-right)
@@ -567,10 +587,10 @@ has just one element then that's the return value."
((f l)
(check-arg procedure? f map)
(check-arg list? l map)
- (let map1 ((in l) (out '()))
- (if (pair? in)
- (map1 (cdr in) (cons (f (car in)) out))
- (reverse! out))))
+ (let map1 ((l l))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
((f l1 l2)
(check-arg procedure? f map)
@@ -583,11 +603,11 @@ has just one element then that's the return value."
(scm-error 'wrong-type-arg "map"
"Args do not contain a proper (finite) list: ~S"
(list (list l1 l2)) #f))
- (let map2 ((l1 l1) (l2 l2) (out '()) (len len))
+ (let map2 ((l1 l1) (l2 l2) (len len))
(if (zero? len)
- (reverse! out)
- (map2 (cdr l1) (cdr l2)
- (cons (f (car l1) (car l2)) out) (1- len))))))
+ '()
+ (cons (f (car l1) (car l2))
+ (map2 (cdr l1) (cdr l2) (1- len)))))))
((f l1 . rest)
(check-arg procedure? f map)
@@ -602,11 +622,11 @@ has just one element then that's the return value."
(scm-error 'wrong-type-arg "map"
"Args do not contain a proper (finite) list: ~S"
(list (cons l1 rest)) #f))
- (let mapn ((l1 l1) (rest rest) (len len) (out '()))
+ (let mapn ((l1 l1) (rest rest) (len len))
(if (zero? len)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest) (1- len)
- (cons (apply f (car l1) (map car rest)) out))))))))
+ '()
+ (cons (apply f (car l1) (map car rest))
+ (mapn (cdr l1) (map cdr rest) (1- len)))))))))
(define map-in-order map)
diff --git a/module/statprof.scm b/module/statprof.scm
index 76dfbea..961f769 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -845,7 +845,8 @@ operation is somewhat expensive."
(let ((state (fresh-profiler-state #:count-calls? count-calls?
#:sampling-period
(inexact->exact (round (/ 1e6 hz)))
- #:outer-cut call-thunk)))
+ #:outer-cut
+ (program-address-range call-thunk))))
(parameterize ((profiler-state state))
(dynamic-wind
(lambda ()
@@ -905,7 +906,8 @@ Since GC does not occur very frequently, you may need to
use the
@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
times."
- (let ((state (fresh-profiler-state #:outer-cut call-thunk)))
+ (let ((state (fresh-profiler-state #:outer-cut
+ (program-address-range call-thunk))))
(parameterize ((profiler-state state))
(define (gc-callback)
(unless (inside-profiler? state)
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 5344d38..8f19c54 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -28,6 +28,8 @@
source:line-for-user
program-sources program-sources-pre-retire program-source
+ program-address-range
+
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
@@ -97,6 +99,15 @@
(lp s sources)
source)))))
+(define (program-address-range program)
+ "Return the start and end addresses of @var{program}'s code, as a pair
+of integers."
+ (let ((pdi (find-program-debug-info (program-code program))))
+ (and pdi
+ (cons (program-debug-info-addr pdi)
+ (+ (program-debug-info-addr pdi)
+ (program-debug-info-size pdi))))))
+
;; 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
diff --git a/test-suite/tests/r5rs_pitfall.test
b/test-suite/tests/r5rs_pitfall.test
index 0bab38c..1d9fcf7 100644
--- a/test-suite/tests/r5rs_pitfall.test
+++ b/test-suite/tests/r5rs_pitfall.test
@@ -1,5 +1,5 @@
;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
-;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2004, 2006, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -292,7 +292,7 @@
;;Not really an error to fail this (Matthias Radestock)
;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
;;tail-recursive. If its (0 0 0), the opposite is true.
-(should-be 8.3 '(0 1 0)
+(should-be 8.3 '(0 0 0)
(let ()
(define executed-k #f)
(define cont #f)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-14-g9de674e,
Andy Wingo <=