[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-923-ga234ab9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-923-ga234ab9 |
|
Date: |
Mon, 14 Apr 2014 14:57:33 +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=a234ab929c65f0627a38131ad6c42f16b3aeae9c
The branch, master has been updated
via a234ab929c65f0627a38131ad6c42f16b3aeae9c (commit)
via 3b14dd2f272920854565011d82b41df1237a2213 (commit)
via 8de051da47e8f0f56a13bde6a4b37ece5f9c81cf (commit)
via 44d9705464d8f54111ed8a8a90d76f0c774e7184 (commit)
from 2ad91e6b34f8aa204f4cd64d9578cc218a35041d (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 a234ab929c65f0627a38131ad6c42f16b3aeae9c
Author: Andy Wingo <address@hidden>
Date: Mon Apr 14 16:54:51 2014 +0200
Better state handling in statprof
* module/statprof.scm (statprof-fold-call-data)
(statprof-proc-call-data): Add optional state arg.
(gcprof): Add optional port arg, and pass state arg explicitly.
(statprof-display-anomalies, statprof-display)
(statprof-call-data->stats): Pass state explicitly.
commit 3b14dd2f272920854565011d82b41df1237a2213
Author: Andy Wingo <address@hidden>
Date: Mon Apr 14 16:31:02 2014 +0200
Optimize make-stack
* libguile/continuations.h:
* libguile/continuations.c (scm_i_continuation_to_frame): Operate on
low-level C structures instead of heap objects.
* libguile/frames.h:
* libguile/frames.c (frame_offset, frame_stack_base): Const args.
(scm_c_frame_closure): New helper.
(scm_frame_procedure): Use the new helper.
* libguile/stacks.c (stack_depth, narrow_stack, scm_make_stack): Rework
to avoid allocating frames as we traverse the stack, and to avoid an
n**2 case where there are outer cuts.
commit 8de051da47e8f0f56a13bde6a4b37ece5f9c81cf
Author: Andy Wingo <address@hidden>
Date: Mon Apr 14 15:14:26 2014 +0200
scm_c_make_frame takes struct scm_frame as arg
* libguile/frames.h:
* libguile/frames.c (scm_c_make_frame): Adapt to take a const struct
scm_frame as the argument. Adapt callers.
* libguile/continuations.c:
* libguile/stacks.c: Adapt callers.
commit 44d9705464d8f54111ed8a8a90d76f0c774e7184
Author: Andy Wingo <address@hidden>
Date: Mon Apr 14 14:54:14 2014 +0200
Refactor to frames code
* libguile/frames.h:
* libguile/frames.c (scm_c_frame_previous): New internal helper.
(scm_frame_previous): Use the helper.
(RELOC): Take kind and low-level frame args separately. Adapt
callers.
(frame_stack_base, frame_offset): New helpers.
(scm_i_frame_offset, scm_i_frame_stack_base): Use low-level helpers.
-----------------------------------------------------------------------
Summary of changes:
libguile/continuations.c | 17 +++--
libguile/continuations.h | 7 ++-
libguile/frames.c | 143 ++++++++++++++++++++++++++++-----------------
libguile/frames.h | 14 +++-
libguile/stacks.c | 133 ++++++++++++++++++++++--------------------
module/statprof.scm | 36 +++++++-----
6 files changed, 203 insertions(+), 147 deletions(-)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index f28d59a..8dca62e 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -168,8 +168,8 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM
vm_cont)
}
#undef FUNC_NAME
-SCM
-scm_i_continuation_to_frame (SCM continuation)
+int
+scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
{
SCM contregs;
scm_t_contregs *cont;
@@ -180,13 +180,16 @@ scm_i_continuation_to_frame (SCM continuation)
if (scm_is_true (cont->vm_cont))
{
struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
- return scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, data,
- (data->fp + data->reloc) - data->stack_base,
- (data->sp + data->reloc) - data->stack_base,
- data->ra);
+
+ frame->stack_holder = data;
+ frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
+ frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
+ frame->ip = data->ra;
+
+ return 1;
}
else
- return SCM_BOOL_F;
+ return 0;
}
struct scm_vm *
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 7d5e0db..ec12b46 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -3,7 +3,7 @@
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2012, 2013 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 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
@@ -76,7 +76,10 @@ SCM_INTERNAL SCM scm_i_make_continuation (int *first,
SCM_INTERNAL void scm_i_check_continuation (SCM cont);
SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
-SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
+struct scm_frame;
+SCM_INTERNAL int scm_i_continuation_to_frame (SCM cont,
+ struct scm_frame *frame);
+
SCM_INTERNAL struct scm_vm* scm_i_contregs_vp (SCM contregs);
SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
diff --git a/libguile/frames.c b/libguile/frames.c
index a651694..6096824 100644
--- a/libguile/frames.c
+++ b/libguile/frames.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
@@ -33,21 +33,17 @@ verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM));
verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
-#define RELOC(frame, val) \
- (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_frame (enum scm_vm_frame_kind frame_kind, void *stack_holder,
- scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
- scm_t_uint32 *ip)
+scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
"vmframe");
- p->stack_holder = stack_holder;
- p->fp_offset = fp_offset;
- p->sp_offset = sp_offset;
- p->ip = ip;
- return scm_cell (scm_tc7_frame | (frame_kind << 8), (scm_t_bits)p);
+ p->stack_holder = frame->stack_holder;
+ p->fp_offset = frame->fp_offset;
+ p->sp_offset = frame->sp_offset;
+ p->ip = frame->ip;
+ return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
}
void
@@ -61,51 +57,58 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state
*pstate)
scm_puts_unlocked (">", port);
}
-SCM*
-scm_i_frame_stack_base (SCM frame)
-#define FUNC_NAME "frame-stack-base"
+static SCM*
+frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
- void *stack_holder;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
-
- switch (SCM_VM_FRAME_KIND (frame))
+ switch (kind)
{
case SCM_VM_FRAME_KIND_CONT:
- return ((struct scm_vm_cont *) stack_holder)->stack_base;
+ return ((struct scm_vm_cont *) frame->stack_holder)->stack_base;
case SCM_VM_FRAME_KIND_VM:
- return ((struct scm_vm *) stack_holder)->stack_base;
+ return ((struct scm_vm *) frame->stack_holder)->stack_base;
default:
abort ();
}
}
+
+static scm_t_ptrdiff
+frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+ switch (kind)
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) frame->stack_holder)->reloc;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return 0;
+
+ default:
+ abort ();
+ }
+}
+
+SCM*
+scm_i_frame_stack_base (SCM frame)
+#define FUNC_NAME "frame-stack-base"
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ return frame_stack_base (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
+}
#undef FUNC_NAME
scm_t_ptrdiff
scm_i_frame_offset (SCM frame)
#define FUNC_NAME "frame-offset"
{
- void *stack_holder;
-
SCM_VALIDATE_VM_FRAME (1, frame);
- stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
-
- switch (SCM_VM_FRAME_KIND (frame))
- {
- case SCM_VM_FRAME_KIND_CONT:
- return ((struct scm_vm_cont *) stack_holder)->reloc;
+ return frame_offset (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
- case SCM_VM_FRAME_KIND_VM:
- return 0;
-
- default:
- abort ();
- }
}
#undef FUNC_NAME
@@ -121,13 +124,27 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
}
#undef FUNC_NAME
+/* Retrieve the local in slot 0, which may or may not actually be a
+ procedure, and may or may not actually be the procedure being
+ applied. If you want the procedure, look it up from the IP. */
+SCM
+scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame
*frame)
+{
+ SCM *fp = frame_stack_base (kind, frame) + frame->fp_offset;
+
+ return SCM_FRAME_PROGRAM (fp);
+}
+
SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+
+ /* FIXME: Retrieve procedure from address? */
+ return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
}
#undef FUNC_NAME
@@ -270,6 +287,9 @@ SCM_DEFINE (scm_frame_return_address,
"frame-return-address", 1, 0, 0,
}
#undef FUNC_NAME
+#define RELOC(kind, frame, val) \
+ (((SCM *) (val)) + frame_offset (kind, frame))
+
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
@@ -279,42 +299,57 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link",
1, 0, 0,
/* fixme: munge fp if holder is a continuation */
return scm_from_uintptr_t
((scm_t_uintptr)
- RELOC (frame,
+ RELOC (SCM_VM_FRAME_KIND (frame), SCM_VM_FRAME_DATA (frame),
SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_frame_previous
+int
+scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
{
SCM *this_fp, *new_fp, *new_sp;
SCM proc;
- SCM_VALIDATE_VM_FRAME (1, frame);
-
again:
- this_fp = SCM_VM_FRAME_FP (frame);
+ this_fp = frame->fp_offset + frame_stack_base (kind, frame);
new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
if (new_fp)
{
- SCM *stack_base = scm_i_frame_stack_base (frame);
- new_fp = RELOC (frame, new_fp);
+ SCM *stack_base = frame_stack_base (kind, frame);
+ new_fp = RELOC (kind, frame, new_fp);
new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
- frame = scm_c_make_frame (SCM_VM_FRAME_KIND (frame),
- SCM_VM_FRAME_STACK_HOLDER (frame),
- new_fp - stack_base, new_sp - stack_base,
- SCM_FRAME_RETURN_ADDRESS (this_fp));
- proc = scm_frame_procedure (frame);
+ frame->fp_offset = new_fp - stack_base;
+ frame->sp_offset = new_sp - stack_base;
+ frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
+
+ proc = SCM_FRAME_PROGRAM (new_fp);
if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
goto again;
else
- return frame;
+ return 1;
}
else
+ return 0;
+}
+
+SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_previous
+{
+ enum scm_vm_frame_kind kind;
+ struct scm_frame tmp;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ kind = SCM_VM_FRAME_KIND (frame);
+ memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
+
+ if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
return SCM_BOOL_F;
+
+ return scm_c_make_frame (kind, &tmp);
}
#undef FUNC_NAME
diff --git a/libguile/frames.h b/libguile/frames.h
index e48bb48..6defff5 100644
--- a/libguile/frames.h
+++ b/libguile/frames.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
@@ -167,9 +167,15 @@ enum scm_vm_frame_kind
SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame);
SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame);
-SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind vm_frame_kind,
- void *stack_holder, scm_t_ptrdiff fp_offset,
- scm_t_ptrdiff sp_offset, scm_t_uint32 *ip);
+/* See notes in frames.c before using this. */
+SCM_INTERNAL SCM scm_c_frame_closure (enum scm_vm_frame_kind kind,
+ const struct scm_frame *frame);
+
+SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind kind,
+ const struct scm_frame *frame);
+
+SCM_INTERNAL int scm_c_frame_previous (enum scm_vm_frame_kind kind,
+ struct scm_frame *frame);
#endif
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 360b35f..182d357 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,5 +1,5 @@
/* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011,
2012, 2013 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011,
2012, 2013, 2014 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -65,11 +65,12 @@ static SCM scm_sys_stacks;
/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (SCM frame)
+stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
- long n = 0;
- /* count frames, skipping boot frames */
- for (; scm_is_true (frame); frame = scm_frame_previous (frame))
+ struct scm_frame tmp;
+ long n = 1;
+ memcpy (&tmp, frame, sizeof tmp);
+ while (scm_c_frame_previous (kind, &tmp))
++n;
return n;
}
@@ -108,24 +109,19 @@ find_prompt (SCM key)
return fp_offset;
}
-static void
-narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
+static long
+narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
+ SCM inner_cut, SCM outer_cut)
{
- unsigned long int len;
- SCM frame;
-
- len = SCM_STACK_LENGTH (stack);
- frame = SCM_STACK_FRAME (stack);
-
/* Cut inner part. */
if (scm_is_true (scm_procedure_p (inner_cut)))
{
/* Cut until the given procedure is seen. */
for (; len ;)
{
- SCM proc = scm_frame_procedure (frame);
+ SCM proc = scm_c_frame_closure (kind, frame);
len--;
- frame = scm_frame_previous (frame);
+ scm_c_frame_previous (kind, frame);
if (scm_is_eq (proc, inner_cut))
break;
}
@@ -138,32 +134,32 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
for (; inner && len; --inner)
{
len--;
- frame = scm_frame_previous (frame);
+ scm_c_frame_previous (kind, frame);
}
}
else
{
/* Cut until the given prompt tag is seen. */
scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
- for (; len; len--, frame = scm_frame_previous (frame))
- if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
+ for (; len; len--, scm_c_frame_previous (kind, frame))
+ if (fp_offset == frame->fp_offset)
break;
}
- SCM_SET_STACK_LENGTH (stack, len);
- SCM_SET_STACK_FRAME (stack, frame);
-
/* Cut outer part. */
if (scm_is_true (scm_procedure_p (outer_cut)))
{
+ long i, new_len;
+ struct scm_frame tmp;
+
+ memcpy (&tmp, frame, sizeof tmp);
+
/* Cut until the given procedure is seen. */
- for (; len ;)
- {
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
- break;
- }
+ for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+ if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
+ new_len = i;
+
+ len = new_len;
}
else if (scm_is_integer (outer_cut))
{
@@ -178,17 +174,23 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
else
{
/* Cut until the given prompt tag is seen. */
+ long i;
+ struct scm_frame tmp;
scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
- while (len)
- {
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
- break;
- }
+
+ memcpy (&tmp, frame, sizeof tmp);
+
+ for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+ if (tmp.fp_offset == fp_offset)
+ break;
+
+ if (i < len)
+ len = i;
+ else
+ len = 0;
}
- SCM_SET_STACK_LENGTH (stack, len);
+ return len;
}
@@ -244,9 +246,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
#define FUNC_NAME s_scm_make_stack
{
long n;
- SCM frame;
- SCM stack;
SCM inner_cut, outer_cut;
+ enum scm_vm_frame_kind kind;
+ struct scm_frame frame;
/* Extract a pointer to the innermost frame of whatever object
scm_make_stack was given. */
@@ -258,43 +260,43 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
cont = scm_i_capture_current_stack ();
c = SCM_VM_CONT_DATA (cont);
- frame = scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, c,
- (c->fp + c->reloc) - c->stack_base,
- (c->sp + c->reloc) - c->stack_base,
- c->ra);
+ kind = SCM_VM_FRAME_KIND_CONT;
+ frame.stack_holder = c;
+ frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
+ frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
+ frame.ip = c->ra;
}
else if (SCM_VM_FRAME_P (obj))
- frame = obj;
+ {
+ kind = SCM_VM_FRAME_KIND (obj);
+ memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
+ }
else if (SCM_CONTINUATIONP (obj))
/* FIXME: Narrowing to prompt tags should narrow with respect to the
prompts
that were in place when the continuation was captured. */
- frame = scm_i_continuation_to_frame (obj);
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_continuation_to_frame (obj, &frame))
+ return SCM_BOOL_F;
+ }
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
/* not reached */
}
- /* FIXME: is this even possible? */
- if (scm_is_true (frame)
- && SCM_PROGRAM_P (scm_frame_procedure (frame))
- && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
- frame = scm_frame_previous (frame);
-
- if (scm_is_false (frame))
+ /* Skip initial boot frame, if any. This is possible if the frame
+ originates from a captured continuation. */
+ if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
+ && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
+ && !scm_c_frame_previous (kind, &frame))
return SCM_BOOL_F;
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
- n = stack_depth (frame);
+ n = stack_depth (kind, &frame);
- /* Make the stack object. */
- stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
- SCM_SET_STACK_LENGTH (stack, n);
- SCM_SET_STACK_ID (stack, scm_stack_id (obj));
- SCM_SET_STACK_FRAME (stack, frame);
-
/* Narrow the stack according to the arguments given to scm_make_stack. */
SCM_VALIDATE_REST_ARGUMENT (args);
while (n > 0 && !scm_is_null (args))
@@ -311,15 +313,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
args = SCM_CDR (args);
}
- narrow_stack (stack,
- inner_cut,
- outer_cut);
-
- n = SCM_STACK_LENGTH (stack);
+ n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
}
if (n > 0)
- return stack;
+ {
+ /* Make the stack object. */
+ SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, scm_stack_id (obj));
+ SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
+ return stack;
+ }
else
return SCM_BOOL_F;
}
diff --git a/module/statprof.scm b/module/statprof.scm
index cf3532e..49b77cf 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -565,7 +565,8 @@ always collects full stacks.)"
(visit-stacks (1+ pos) (cons (reverse stack) out))))))
(else (reverse out))))))
-(define (statprof-fold-call-data proc init)
+(define* (statprof-fold-call-data proc init #:optional
+ (state (existing-profiler-state)))
"Fold @var{proc} over the call-data accumulated by statprof. Cannot be
called while statprof is active. @var{proc} should take two arguments,
@code{(@var{call-data} @var{prior-result})}.
@@ -578,14 +579,15 @@ it represents different functions with the same name."
(lambda (key value prior-result)
(proc value prior-result))
init
- (stack-samples->procedure-data (existing-profiler-state))))
+ (stack-samples->procedure-data state)))
-(define (statprof-proc-call-data proc)
+(define* (statprof-proc-call-data proc #:optional
+ (state (existing-profiler-state)))
"Returns the call-data associated with @var{proc}, or @code{#f} if
none is available."
(when (statprof-active?)
(error "Can't call statprof-proc-call-data while profiler is running."))
- (hashv-ref (stack-samples->procedure-data (existing-profiler-state))
+ (hashv-ref (stack-samples->procedure-data state)
(cond
((primitive? proc) (procedure-name proc))
((program? proc) (program-code proc))
@@ -616,9 +618,9 @@ none is available."
(proc-source (and=> (call-data-source call-data) source->string))
(self-samples (call-data-self-sample-count call-data))
(cum-samples (call-data-cum-sample-count call-data))
- (all-samples (statprof-sample-count))
- (secs-per-sample (/ (statprof-accumulated-time)
- (statprof-sample-count)))
+ (all-samples (statprof-sample-count state))
+ (secs-per-sample (/ (statprof-accumulated-time state)
+ (statprof-sample-count state)))
(num-calls (and (call-counts state)
(statprof-call-data-calls call-data))))
@@ -657,14 +659,15 @@ none is available."
"Displays a gprof-like summary of the statistics collected. Unless an
optional @var{port} argument is passed, uses the current output port."
(cond
- ((zero? (statprof-sample-count))
+ ((zero? (statprof-sample-count state))
(format port "No samples recorded.\n"))
(else
(let* ((stats-list (statprof-fold-call-data
(lambda (data prior-value)
(cons (statprof-call-data->stats data)
prior-value))
- '()))
+ '()
+ state))
(sorted-stats (sort stats-list stats-sorter)))
(define (display-stats-line stats)
@@ -705,9 +708,9 @@ optional @var{port} argument is passed, uses the current
output port."
(for-each display-stats-line sorted-stats)
(display "---\n" port)
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state))
(simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
- (statprof-accumulated-time)
+ (statprof-accumulated-time state)
(/ (gc-time-taken state)
1.0 internal-time-units-per-second))))))
@@ -725,9 +728,10 @@ address@hidden"
(call-data-name data)
(call-data-call-count data)
(call-data-cum-sample-count data))))
- #f)
- (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
+ #f
+ state)
+ (simple-format #t "Total time: ~A\n" (statprof-accumulated-time state))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state)))
(define (statprof-display-anomolies)
(issue-deprecation-warning "statprof-display-anomolies is a misspelling. "
@@ -884,7 +888,7 @@ default: @code{#f}
#:count-calls? ,(kw-arg-ref #:count-calls? args #f)
#:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
-(define* (gcprof thunk #:key (loop 1) full-stacks?)
+(define* (gcprof thunk #:key (loop 1) full-stacks? (port
(current-output-port)))
"Do an allocation profile of the execution of @var{thunk}.
The stack will be sampled soon after every garbage collection, yielding
@@ -930,4 +934,4 @@ times."
(gc-time-taken state)))
(accumulate-time state (get-internal-run-time))
(set-profile-level! state 0)
- (statprof-display))))))
+ (statprof-display port state))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-923-ga234ab9,
Andy Wingo <=