/* 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
/* 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;
}
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);
+ /* 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)))
/* 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;
}
}
+ 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. */
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 ;)
+ 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_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))
{
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
- break;
+ 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))
{
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;
}
\f
"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"
"@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;
- 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. */
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 if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
+ &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))
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;
}
else if (SCM_CONTINUATIONP (stack))
/* FIXME: implement me */
return SCM_BOOL_F;
+ else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
HCoop / bpt / guile.git / blobdiff