X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/a6029b97ea84d9e9a13d71b21213b6fd0be41e87..03d1294977333b23b91e24c3b0b7ddf9cab26cfc:/libguile/frames.c diff --git a/libguile/frames.c b/libguile/frames.c index 29c14c8f1..b0f451f7d 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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,38 +24,90 @@ #include #include "_scm.h" #include "frames.h" +#include "vm.h" +#include - -scm_t_bits scm_tc16_frame; +/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */ +verify (sizeof (SCM) == sizeof (SCM *)); +verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM)); +verify (offsetof (struct scm_vm_frame, dynamic_link) == 0); -#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame)) + +#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 frame_kind, void *stack_holder, + scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset, + scm_t_uint32 *ip) { struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame), "vmframe"); p->stack_holder = stack_holder; - p->fp = fp; - p->sp = sp; + p->fp_offset = fp_offset; + p->sp_offset = sp_offset; p->ip = ip; - p->offset = offset; - SCM_RETURN_NEWSMOB (scm_tc16_frame, p); + return scm_cell (scm_tc7_frame | (frame_kind << 8), (scm_t_bits)p); } -static int -frame_print (SCM frame, SCM port, scm_print_state *pstate) +void +scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) { - scm_puts ("#", port); + scm_puts_unlocked (">", port); +} + +SCM* +scm_i_frame_stack_base (SCM frame) +#define FUNC_NAME "frame-stack-base" +{ + 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)->stack_base; + + case SCM_VM_FRAME_KIND_VM: + return ((struct scm_vm *) stack_holder)->stack_base; + + default: + abort (); + } +} +#undef FUNC_NAME + +scm_t_ptrdiff +scm_i_frame_offset (SCM frame) +#define FUNC_NAME "frame-offset" +{ + void *stack_holder; - return 1; + 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; + + default: + abort (); + } } +#undef FUNC_NAME /* Scheme interface */ @@ -96,78 +148,50 @@ SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, } #undef FUNC_NAME -SCM -scm_frame_source (SCM frame) +SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_source { - static SCM var = SCM_BOOL_F; - - if (scm_is_false (var)) - var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"), - "frame-source"); + SCM_VALIDATE_VM_FRAME (1, frame); - return scm_call_1 (SCM_VARIABLE_REF (var), frame); + 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 *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)); - while (p <= sp) - { - if (p + 1 < sp && p[1] == (SCM)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 (p + 1 < sp && p[1] == (SCM)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 @@ -178,72 +202,65 @@ 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 (p + 1 < sp && p[1] == (SCM)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 -SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0, +SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0, (SCM frame), - "") -#define FUNC_NAME s_scm_frame_instruction_pointer + "Return the frame pointer for @var{frame}.") +#define FUNC_NAME s_scm_frame_address { - const struct scm_objcode *c_objcode; + SCM_VALIDATE_VM_FRAME (1, frame); + return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (frame)); +} +#undef FUNC_NAME +SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_stack_pointer +{ SCM_VALIDATE_VM_FRAME (1, frame); - c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame)); - return scm_from_ulong ((unsigned long) - (SCM_VM_FRAME_IP (frame) - - SCM_C_OBJCODE_BASE (c_objcode))); + return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (frame)); } #undef FUNC_NAME -SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, +SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0, (SCM frame), "") -#define FUNC_NAME s_scm_frame_return_address +#define FUNC_NAME s_scm_frame_instruction_pointer { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_ulong ((unsigned long) - (SCM_FRAME_RETURN_ADDRESS - (SCM_VM_FRAME_FP (frame)))); + + return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame)); } #undef FUNC_NAME -SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0, +SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, (SCM frame), "") -#define FUNC_NAME s_scm_frame_mv_return_address +#define FUNC_NAME s_scm_frame_return_address { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_ulong ((unsigned long) - (SCM_FRAME_MV_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 @@ -254,8 +271,8 @@ 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) + return scm_from_uintptr_t + ((scm_t_uintptr) RELOC (frame, SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)))); } @@ -267,6 +284,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, #define FUNC_NAME s_scm_frame_previous { SCM *this_fp, *new_fp, *new_sp; + SCM proc; SCM_VALIDATE_VM_FRAME (1, frame); @@ -274,13 +292,17 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, 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)); - if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame))) + { + 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; @@ -291,13 +313,6 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, #undef FUNC_NAME -void -scm_bootstrap_frames (void) -{ - scm_tc16_frame = scm_make_smob_type ("frame", 0); - scm_set_smob_print (scm_tc16_frame, frame_print); -} - void scm_init_frames (void) {