X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/79a6c3be6a7085e5a602f5306f162e5c93c1636a..fb50a753e125f77093826963fd786b9592f7e08d:/libguile/frames.c diff --git a/libguile/frames.c b/libguile/frames.c index 8ce5aa0b0..2162f49ce 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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 @@ -24,29 +24,26 @@ #include #include "_scm.h" #include "frames.h" +#include "vm.h" #include /* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */ verify (sizeof (SCM) == sizeof (SCM *)); -verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM)); +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 (SCM stack_holder, SCM *fp, SCM *sp, - scm_t_uint8 *ip, scm_t_ptrdiff offset) +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 = fp; - p->sp = sp; - p->ip = ip; - p->offset = offset; - return scm_cell (scm_tc7_frame, (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 @@ -60,6 +57,61 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) scm_puts_unlocked (">", port); } +static SCM* +frame_stack_base (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)->stack_base; + + case SCM_VM_FRAME_KIND_VM: + 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" +{ + SCM_VALIDATE_VM_FRAME (1, frame); + + return frame_offset (SCM_VM_FRAME_KIND (frame), + SCM_VM_FRAME_DATA (frame)); + +} +#undef FUNC_NAME + /* Scheme interface */ @@ -72,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; - return scm_call_1 (SCM_VARIABLE_REF (var), frame); +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 (frame_call_representation_var), frame); } #undef FUNC_NAME @@ -104,91 +203,45 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, "") #define FUNC_NAME s_scm_frame_source { - SCM proc; - SCM_VALIDATE_VM_FRAME (1, frame); - proc = scm_frame_procedure (frame); - - if (SCM_PROGRAM_P (proc)) - return scm_program_source (scm_frame_procedure (frame), - scm_frame_instruction_pointer (frame), - SCM_UNDEFINED); - - return SCM_BOOL_F; + return scm_find_source_for_addr (scm_frame_instruction_pointer (frame)); } #undef FUNC_NAME -/* The number of locals would be a simple thing to compute, if it weren't for - the presence of not-yet-active frames on the stack. So we have a cheap - heuristic to detect not-yet-active frames, and skip over them. Perhaps we - should represent them more usefully. -*/ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, (SCM frame), "") #define FUNC_NAME s_scm_frame_num_locals { - SCM *fp, *sp, *p; - unsigned int n = 0; + SCM *fp, *sp; SCM_VALIDATE_VM_FRAME (1, frame); fp = SCM_VM_FRAME_FP (frame); sp = SCM_VM_FRAME_SP (frame); - p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - - if (SCM_RTL_PROGRAM_P (fp[-1])) - /* The frame size of an RTL program is fixed, except in the case of - passing a wrong number of arguments to the program. So we do - need to use an SP for determining the number of locals. */ - return scm_from_uint32 (sp + 1 - p); - sp = SCM_VM_FRAME_SP (frame); - p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - while (p <= sp) - { - if (SCM_UNPACK (p[0]) == 0) - /* skip over not-yet-active frame */ - p += 3; - else - { - p++; - n++; - } - } - return scm_from_uint (n); + return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp)); } #undef FUNC_NAME -/* Need same not-yet-active frame logic here as in frame-num-locals */ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, (SCM frame, SCM index), "") #define FUNC_NAME s_scm_frame_local_ref { - SCM *sp, *p; - unsigned int n = 0; + SCM *fp, *sp; unsigned int i; SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_UINT_COPY (2, index, i); + fp = SCM_VM_FRAME_FP (frame); sp = SCM_VM_FRAME_SP (frame); - p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - while (p <= sp) - { - if (SCM_UNPACK (p[0]) == 0) - /* skip over not-yet-active frame */ - p += 3; - else if (n == i) - return *p; - else - { - p++; - n++; - } - } + + if (i < SCM_FRAME_NUM_LOCALS (fp, sp)) + return SCM_FRAME_LOCAL (fp, i); + SCM_OUT_OF_RANGE (SCM_ARG2, index); } #undef FUNC_NAME @@ -199,31 +252,21 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, "") #define FUNC_NAME s_scm_frame_local_set_x { - SCM *sp, *p; - unsigned int n = 0; + SCM *fp, *sp; unsigned int i; SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_UINT_COPY (2, index, i); + fp = SCM_VM_FRAME_FP (frame); sp = SCM_VM_FRAME_SP (frame); - p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - while (p <= sp) + + if (i < SCM_FRAME_NUM_LOCALS (fp, sp)) { - if (SCM_UNPACK (p[0]) == 0) - /* skip over not-yet-active frame */ - p += 3; - else if (n == i) - { - *p = val; - return SCM_UNSPECIFIED; - } - else - { - p++; - n++; - } + SCM_FRAME_LOCAL (fp, i) = val; + return SCM_UNSPECIFIED; } + SCM_OUT_OF_RANGE (SCM_ARG2, index); } #undef FUNC_NAME @@ -234,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_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_FP (frame)); + return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame)); } #undef FUNC_NAME @@ -245,7 +288,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_SP (frame)); + return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame)); } #undef FUNC_NAME @@ -254,18 +297,9 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0, "") #define FUNC_NAME s_scm_frame_instruction_pointer { - SCM program; - const struct scm_objcode *c_objcode; - SCM_VALIDATE_VM_FRAME (1, frame); - program = scm_frame_procedure (frame); - - if (!SCM_PROGRAM_P (program)) - return SCM_INUM0; - c_objcode = SCM_PROGRAM_DATA (program); - return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame) - - SCM_C_OBJCODE_BASE (c_objcode))); + return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame)); } #undef FUNC_NAME @@ -275,23 +309,13 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, #define FUNC_NAME s_scm_frame_return_address { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_unsigned_integer ((scm_t_bits) - (SCM_FRAME_RETURN_ADDRESS - (SCM_VM_FRAME_FP (frame)))); + return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS + (SCM_VM_FRAME_FP (frame)))); } #undef FUNC_NAME -SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_frame_mv_return_address -{ - SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_unsigned_integer ((scm_t_bits) - (SCM_FRAME_MV_RETURN_ADDRESS - (SCM_VM_FRAME_FP (frame)))); -} -#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), @@ -300,43 +324,66 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, { SCM_VALIDATE_VM_FRAME (1, frame); /* fixme: munge fp if holder is a continuation */ - return scm_from_ulong - ((unsigned long) - RELOC (frame, + return scm_from_uintptr_t + ((scm_t_uintptr) + 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) - { - new_fp = RELOC (frame, new_fp); - new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1; - frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame), - new_fp, new_sp, - SCM_FRAME_RETURN_ADDRESS (this_fp), - SCM_VM_FRAME_OFFSET (frame)); - 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