X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/d511a2e160ae808336d94683fe515a34247d3e4f..fb50a753e125f77093826963fd786b9592f7e08d:/libguile/frames.c diff --git a/libguile/frames.c b/libguile/frames.c index b0f451f7d..2162f49ce 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; - - case SCM_VM_FRAME_KIND_VM: - return 0; + return frame_offset (SCM_VM_FRAME_KIND (frame), + SCM_VM_FRAME_DATA (frame)); - default: - abort (); - } } #undef FUNC_NAME @@ -121,30 +124,77 @@ 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, *sp; + + fp = frame_stack_base (kind, frame) + frame->fp_offset; + sp = frame_stack_base (kind, frame) + frame->sp_offset; + + if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0) + return SCM_FRAME_LOCAL (fp, 0); + + return SCM_BOOL_F; +} + 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 +static SCM frame_arguments_var; + +static void +init_frame_arguments_var (void) +{ + frame_arguments_var + = scm_c_private_lookup ("system vm frame", "frame-arguments"); +} + SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, (SCM frame), "") #define FUNC_NAME s_scm_frame_arguments { - static SCM var = SCM_BOOL_F; - + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_frame_arguments_var); + SCM_VALIDATE_VM_FRAME (1, frame); - if (scm_is_false (var)) - var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"), - "frame-arguments"); + return scm_call_1 (scm_variable_ref (frame_arguments_var), frame); +} +#undef FUNC_NAME + +static SCM frame_call_representation_var; + +static void +init_frame_call_representation_var (void) +{ + frame_call_representation_var + = scm_c_private_lookup ("system vm frame", "frame-call-representation"); +} + +SCM scm_frame_call_representation (SCM frame) +#define FUNC_NAME "frame-call-representation" +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_frame_call_representation_var); + + SCM_VALIDATE_VM_FRAME (1, frame); - return scm_call_1 (SCM_VARIABLE_REF (var), frame); + return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame); } #undef FUNC_NAME @@ -227,7 +277,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0, #define FUNC_NAME s_scm_frame_address { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame)); + return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame)); } #undef FUNC_NAME @@ -238,7 +288,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame)); + return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame)); } #undef FUNC_NAME @@ -264,6 +314,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), "") @@ -273,42 +326,64 @@ 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 +int +scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) +{ + SCM *this_fp, *new_fp, *new_sp; + SCM *stack_base = frame_stack_base (kind, frame); + + again: + this_fp = frame->fp_offset + stack_base; + + if (this_fp == stack_base) + return 0; + + new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp); + + if (!new_fp) + return 0; + + new_fp = RELOC (kind, frame, new_fp); + + if (new_fp < stack_base) + return 0; + + new_sp = SCM_FRAME_PREVIOUS_SP (this_fp); + frame->fp_offset = new_fp - stack_base; + frame->sp_offset = new_sp - stack_base; + frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp); + + { + SCM proc = scm_c_frame_closure (kind, frame); + if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc)) + goto again; + } + + return 1; +} + SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, (SCM frame), "") #define FUNC_NAME s_scm_frame_previous { - SCM *this_fp, *new_fp, *new_sp; - SCM proc; + enum scm_vm_frame_kind kind; + struct scm_frame tmp; SCM_VALIDATE_VM_FRAME (1, frame); - again: - this_fp = SCM_VM_FRAME_FP (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); - 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); - - if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc)) - goto again; - else - return frame; - } - else + 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