diff options
Diffstat (limited to 'libguile/stacks.c')
-rw-r--r-- | libguile/stacks.c | 345 |
1 files changed, 92 insertions, 253 deletions
diff --git a/libguile/stacks.c b/libguile/stacks.c index 16c851f6e..21c288fcf 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,4 +1,4 @@ -/* Representation of stack frame debug information +/* A stack holds a frame chain * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or @@ -42,14 +42,10 @@ -/* {Frames and stacks} +/* {Stacks} * - * The stack is represented as a struct with an id slot and a tail - * array of scm_t_info_frame structs. - * - * A frame is represented as a pair where the car contains a stack and - * the cdr an inum. The inum is an index to the first SCM value of - * the scm_t_info_frame struct. + * The stack is represented as a struct that holds a frame. The frame itself is + * linked to the next frame, or #f. * * Stacks * Constructor @@ -59,71 +55,26 @@ * stack-ref * Inspector * stack-length - * - * Frames - * Constructor - * last-stack-frame - * Selectors - * frame-number - * frame-source - * frame-procedure - * frame-arguments - * frame-previous - * frame-next - * Predicates - * frame-real? - * frame-procedure? - * frame-evaluating-args? - * frame-overflow? */ + */ -static SCM stack_id_with_fp (SCM vmframe, SCM **fp); +static SCM stack_id_with_fp (SCM frame, SCM **fp); -/* Count number of debug info frames on a stack, beginning with VMFRAME. +/* Count number of debug info frames on a stack, beginning with FRAME. */ static long -stack_depth (SCM vmframe, SCM *fp) +stack_depth (SCM frame, SCM *fp) { long n; - /* count vmframes, skipping boot frames */ - for (; scm_is_true (vmframe) && SCM_VM_FRAME_FP (vmframe) > fp; - vmframe = scm_c_vm_frame_prev (vmframe)) - if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + /* count frames, skipping boot frames */ + for (; scm_is_true (frame) && SCM_VM_FRAME_FP (frame) > fp; + frame = scm_c_frame_prev (frame)) + if (!SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame))) ++n; return n; } -/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames - * starting with the first stack frame represented by VMFRAME. - */ - -static scm_t_bits -read_frames (SCM vmframe, long n, scm_t_info_frame *iframes) -{ - scm_t_info_frame *iframe = iframes; - - for (; scm_is_true (vmframe); - vmframe = scm_c_vm_frame_prev (vmframe)) - { - if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) - /* skip boot frame */ - continue; - else - { - /* Oh dear, oh dear, oh dear. */ - iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC; - iframe->source = scm_vm_frame_source (vmframe); - iframe->proc = scm_vm_frame_program (vmframe); - iframe->args = scm_vm_frame_arguments (vmframe); - ++iframe; - if (--n == 0) - break; - } - } - return iframe - iframes; /* Number of frames actually read */ -} - /* Narrow STACK by cutting away stackframes (mutatingly). * * Inner frames (most recent) are cut by advancing the frames pointer. @@ -148,33 +99,48 @@ read_frames (SCM vmframe, long n, scm_t_info_frame *iframes) static void narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) { - scm_t_stack *s = SCM_STACK (stack); - unsigned long int i; - long n = s->length; + unsigned long int len; + SCM frame; + len = SCM_STACK_LENGTH (stack); + frame = SCM_STACK_FRAME (stack); + /* Cut inner part. */ if (scm_is_eq (inner_key, SCM_BOOL_T)) { - /* Cut all frames up to user module code */ - for (i = 0; inner; ++i, --inner) - ; + /* Cut specified number of frames. */ + for (; inner && len; --inner) + { + len--; + frame = scm_c_frame_prev (frame); + } } else - /* Use standard cutting procedure. */ { - for (i = 0; inner; --inner) - if (scm_is_eq (s->frames[i++].proc, inner_key)) - break; + /* Cut until the given procedure is seen. */ + for (; inner && len ; --inner) + { + SCM proc = scm_frame_procedure (frame); + len--; + frame = scm_c_frame_prev (frame); + if (scm_is_eq (proc, inner_key)) + break; + } } - s->frames = &s->frames[i]; - n -= i; + + SCM_SET_STACK_LENGTH (stack, len); + SCM_SET_STACK_FRAME (stack, frame); /* Cut outer part. */ - for (; n && outer; --outer) - if (scm_is_eq (s->frames[--n].proc, outer_key)) - break; + for (; outer && len ; --outer) + { + frame = scm_stack_ref (stack, scm_from_long (len - 1)); + len--; + if (scm_is_eq (scm_frame_procedure (frame), outer_key)) + break; + } - s->length = n; + SCM_SET_STACK_LENGTH (stack, len); } @@ -220,10 +186,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, "taken as 0.") #define FUNC_NAME s_scm_make_stack { - long n, size; + long n; int maxp; - scm_t_info_frame *iframe; - SCM vmframe; + SCM frame; SCM stack; SCM id, *id_fp; SCM inner_cut, outer_cut; @@ -232,11 +197,18 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, scm_make_stack was given. */ if (scm_is_eq (obj, SCM_BOOL_T)) { - struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); - vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); + SCM cont; + struct scm_vm_cont *c; + + cont = scm_cdar (scm_vm_capture_continuations ()); + c = SCM_VM_CONT_DATA (cont); + + frame = scm_c_make_frame (cont, c->fp + c->reloc, + c->sp + c->reloc, c->ip, + c->reloc); } else if (SCM_VM_FRAME_P (obj)) - vmframe = obj; + frame = obj; else if (SCM_CONTINUATIONP (obj)) { scm_t_contregs *cont = SCM_CONTREGS (obj); @@ -245,13 +217,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, struct scm_vm_cont *data; vm_cont = scm_cdr (scm_car (cont->vm_conts)); data = SCM_VM_CONT_DATA (vm_cont); - vmframe = scm_c_make_vm_frame (vm_cont, - data->fp + data->reloc, - data->sp + data->reloc, - data->ip, - data->reloc); + frame = scm_c_make_frame (vm_cont, + data->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); } else - vmframe = SCM_BOOL_F; + frame = SCM_BOOL_F; } else { @@ -259,36 +231,25 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* not reached */ } - if (scm_is_false (vmframe)) + if (scm_is_false (frame)) return SCM_BOOL_F; /* Get ID of the stack corresponding to the given frame. */ - id = stack_id_with_fp (vmframe, &id_fp); + id = stack_id_with_fp (frame, &id_fp); /* Count number of frames. Also get stack id tag and check whether there are more stackframes than we want to record (SCM_BACKTRACE_MAXDEPTH). */ id = SCM_BOOL_F; maxp = 0; - n = stack_depth (vmframe, id_fp); - /* FIXME: redo maxp? */ - size = n * SCM_FRAME_N_SLOTS; + n = stack_depth (frame, id_fp); /* Make the stack object. */ - stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL); - SCM_STACK (stack) -> id = id; - iframe = &SCM_STACK (stack) -> tail[0]; - SCM_STACK (stack) -> frames = iframe; - SCM_STACK (stack) -> length = n; - - /* Translate the current chain of stack frames into debugging information. */ - n = read_frames (vmframe, n, iframe); - if (n != SCM_STACK (stack)->length) - { - scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); - SCM_STACK (stack)->length = n; - } - + stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL); + SCM_SET_STACK_LENGTH (stack, n); + SCM_SET_STACK_ID (stack, id); + 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,12 +272,9 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, scm_is_integer (outer_cut) ? 0 : outer_cut); - n = SCM_STACK (stack) -> length; + n = SCM_STACK_LENGTH (stack); } - if (n > 0 && maxp) - iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; - if (n > 0) return stack; else @@ -329,15 +287,15 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, "Return the identifier given to @var{stack} by @code{start-stack}.") #define FUNC_NAME s_scm_stack_id { - SCM vmframe, *id_fp; + SCM frame, *id_fp; if (scm_is_eq (stack, SCM_BOOL_T)) { struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); - vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); + frame = scm_c_make_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); } else if (SCM_VM_FRAME_P (stack)) - vmframe = stack; + frame = stack; else if (SCM_CONTINUATIONP (stack)) { scm_t_contregs *cont = SCM_CONTREGS (stack); @@ -346,13 +304,13 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, struct scm_vm_cont *data; vm_cont = scm_cdr (scm_car (cont->vm_conts)); data = SCM_VM_CONT_DATA (vm_cont); - vmframe = scm_c_make_vm_frame (vm_cont, - data->fp + data->reloc, - data->sp + data->reloc, - data->ip, - data->reloc); + frame = scm_c_make_frame (vm_cont, + data->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); } else - vmframe = SCM_BOOL_F; + frame = SCM_BOOL_F; } else { @@ -360,14 +318,14 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, /* not reached */ } - return stack_id_with_fp (vmframe, &id_fp); + return stack_id_with_fp (frame, &id_fp); } #undef FUNC_NAME static SCM -stack_id_with_fp (SCM vmframe, SCM **fp) +stack_id_with_fp (SCM frame, SCM **fp) { - SCM holder = SCM_VM_FRAME_STACK_HOLDER (vmframe); + SCM holder = SCM_VM_FRAME_STACK_HOLDER (frame); if (SCM_VM_CONT_P (holder)) { @@ -387,10 +345,18 @@ SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, #define FUNC_NAME s_scm_stack_ref { unsigned long int c_index; + SCM frame; SCM_VALIDATE_STACK (1, stack); c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); - return scm_cons (stack, index); + frame = SCM_STACK_FRAME (stack); + while (c_index--) + { + frame = scm_c_frame_prev (frame); + while (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame))) + frame = scm_c_frame_prev (frame); + } + return frame; } #undef FUNC_NAME @@ -400,134 +366,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, #define FUNC_NAME s_scm_stack_length { SCM_VALIDATE_STACK (1, stack); - return scm_from_int (SCM_STACK_LENGTH (stack)); -} -#undef FUNC_NAME - -/* Frames - */ - -SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a stack frame.") -#define FUNC_NAME s_scm_frame_p -{ - return scm_from_bool(SCM_FRAMEP (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, - (SCM frame), - "Return the frame number of @var{frame}.") -#define FUNC_NAME s_scm_frame_number -{ - SCM_VALIDATE_FRAME (1, frame); - return scm_from_int (SCM_FRAME_NUMBER (frame)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, - (SCM frame), - "Return the source of @var{frame}.") -#define FUNC_NAME s_scm_frame_source -{ - SCM_VALIDATE_FRAME (1, frame); - return SCM_FRAME_SOURCE (frame); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, - (SCM frame), - "Return the procedure for @var{frame}, or @code{#f} if no\n" - "procedure is associated with @var{frame}.") -#define FUNC_NAME s_scm_frame_procedure -{ - SCM_VALIDATE_FRAME (1, frame); - return (SCM_FRAME_PROC_P (frame) - ? SCM_FRAME_PROC (frame) - : SCM_BOOL_F); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, - (SCM frame), - "Return the arguments of @var{frame}.") -#define FUNC_NAME s_scm_frame_arguments -{ - SCM_VALIDATE_FRAME (1, frame); - return SCM_FRAME_ARGS (frame); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, - (SCM frame), - "Return the previous frame of @var{frame}, or @code{#f} if\n" - "@var{frame} is the first frame in its stack.") -#define FUNC_NAME s_scm_frame_previous -{ - unsigned long int n; - SCM_VALIDATE_FRAME (1, frame); - n = scm_to_ulong (SCM_CDR (frame)) + 1; - if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) - return SCM_BOOL_F; - else - return scm_cons (SCM_CAR (frame), scm_from_ulong (n)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, - (SCM frame), - "Return the next frame of @var{frame}, or @code{#f} if\n" - "@var{frame} is the last frame in its stack.") -#define FUNC_NAME s_scm_frame_next -{ - unsigned long int n; - SCM_VALIDATE_FRAME (1, frame); - n = scm_to_ulong (SCM_CDR (frame)); - if (n == 0) - return SCM_BOOL_F; - else - return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, - (SCM frame), - "Return @code{#t} if @var{frame} is a real frame.") -#define FUNC_NAME s_scm_frame_real_p -{ - SCM_VALIDATE_FRAME (1, frame); - return scm_from_bool(SCM_FRAME_REAL_P (frame)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, - (SCM frame), - "Return @code{#t} if a procedure is associated with @var{frame}.") -#define FUNC_NAME s_scm_frame_procedure_p -{ - SCM_VALIDATE_FRAME (1, frame); - return scm_from_bool(SCM_FRAME_PROC_P (frame)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, - (SCM frame), - "Return @code{#t} if @var{frame} contains evaluated arguments.") -#define FUNC_NAME s_scm_frame_evaluating_args_p -{ - SCM_VALIDATE_FRAME (1, frame); - return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, - (SCM frame), - "Return @code{#t} if @var{frame} is an overflow frame.") -#define FUNC_NAME s_scm_frame_overflow_p -{ - SCM_VALIDATE_FRAME (1, frame); - return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame)); + return scm_from_long (SCM_STACK_LENGTH (stack)); } #undef FUNC_NAME |