X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/dc7a33fa871c42d0474602f3560d3ce350e1f1c3..d8d9a8da05ec876acba81a559798eb5eeceb5a17:/libguile/stacks.c diff --git a/libguile/stacks.c b/libguile/stacks.c index 360b35f7b..a09c3b9a3 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,14 +109,25 @@ 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); + /* 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))) @@ -123,13 +135,32 @@ narrow_stack (SCM stack, SCM inner_cut, SCM outer_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. */ @@ -138,32 +169,56 @@ 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 ;) + 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)) { @@ -178,17 +233,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; } @@ -215,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" @@ -223,30 +285,34 @@ 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; - 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 +324,50 @@ 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 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)) @@ -311,15 +384,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; } @@ -342,6 +418,9 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, 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);