123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480 |
- #if HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <stdlib.h>
- #include <string.h>
- #include "_scm.h"
- #include "frames.h"
- #include "vm.h"
- SCM
- 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 = 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
- scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
- {
- scm_puts_unlocked ("#<frame ", port);
- scm_uintprint (SCM_UNPACK (frame), 16, port);
- if (scm_module_system_booted_p)
- {
- SCM name = scm_frame_procedure_name (frame);
- if (scm_is_true (name))
- {
- scm_putc_unlocked (' ', port);
- scm_write (name, port);
- }
- }
-
- scm_puts_unlocked (">", port);
- }
- static union scm_vm_stack_element*
- frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
- {
- switch (kind)
- {
- case SCM_VM_FRAME_KIND_CONT:
- {
- struct scm_vm_cont *cont = frame->stack_holder;
- return cont->stack_bottom + cont->stack_size;
- }
- case SCM_VM_FRAME_KIND_VM:
- return ((struct scm_vm *) frame->stack_holder)->stack_top;
- 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 ();
- }
- }
- union scm_vm_stack_element*
- scm_i_frame_stack_top (SCM frame)
- #define FUNC_NAME "frame-stack-top"
- {
- SCM_VALIDATE_VM_FRAME (1, frame);
- return frame_stack_top (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
- SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
- (SCM obj),
- "")
- #define FUNC_NAME s_scm_frame_p
- {
- return scm_from_bool (SCM_VM_FRAME_P (obj));
- }
- #undef FUNC_NAME
- SCM
- scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
- {
- union scm_vm_stack_element *fp, *sp;
- fp = frame_stack_top (kind, frame) - frame->fp_offset;
- sp = frame_stack_top (kind, frame) - frame->sp_offset;
- if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
- return SCM_FRAME_LOCAL (fp, 0);
- return SCM_BOOL_F;
- }
- static SCM frame_procedure_name_var;
- static void
- init_frame_procedure_name_var (void)
- {
- frame_procedure_name_var
- = scm_c_private_lookup ("system vm frame", "frame-procedure-name");
- }
- SCM_DEFINE (scm_frame_procedure_name, "frame-procedure-name", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_procedure_name
- {
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- scm_i_pthread_once (&once, init_frame_procedure_name_var);
- SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_call_1 (scm_variable_ref (frame_procedure_name_var), 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_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);
- 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 (frame_call_representation_var), frame);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_source
- {
- SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
- }
- #undef FUNC_NAME
- static const char s_scm_frame_num_locals[] = "frame-num-locals";
- static SCM
- scm_frame_num_locals (SCM frame)
- #define FUNC_NAME s_scm_frame_num_locals
- {
- union scm_vm_stack_element *fp, *sp;
- SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- sp = SCM_VM_FRAME_SP (frame);
- return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
- }
- #undef FUNC_NAME
- enum stack_item_representation
- {
- STACK_ITEM_SCM = 0,
- STACK_ITEM_F64 = 1,
- STACK_ITEM_U64 = 2,
- STACK_ITEM_S64 = 3
- };
- static enum stack_item_representation
- scm_to_stack_item_representation (SCM x, const char *subr, int pos)
- {
- if (scm_is_eq (x, scm_from_latin1_symbol ("scm")))
- return STACK_ITEM_SCM;
- if (scm_is_eq (x, scm_from_latin1_symbol ("f64")))
- return STACK_ITEM_F64;
- if (scm_is_eq (x, scm_from_latin1_symbol ("u64")))
- return STACK_ITEM_U64;
- if (scm_is_eq (x, scm_from_latin1_symbol ("s64")))
- return STACK_ITEM_S64;
- scm_wrong_type_arg (subr, pos, x);
- return 0;
- }
- static const char s_scm_frame_local_ref[] = "frame-local-ref";
- static SCM
- scm_frame_local_ref (SCM frame, SCM index, SCM representation)
- #define FUNC_NAME s_scm_frame_local_ref
- {
- union scm_vm_stack_element *fp, *sp;
- unsigned int i;
- enum stack_item_representation repr;
- SCM_VALIDATE_VM_FRAME (1, frame);
- SCM_VALIDATE_UINT_COPY (2, index, i);
- repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
- fp = SCM_VM_FRAME_FP (frame);
- sp = SCM_VM_FRAME_SP (frame);
- if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
- {
- union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
- switch (repr)
- {
- case STACK_ITEM_SCM:
- return item->as_scm;
- case STACK_ITEM_F64:
- return scm_from_double (item->as_f64);
- case STACK_ITEM_U64:
- return scm_from_uint64 (item->as_u64);
- case STACK_ITEM_S64:
- return scm_from_int64 (item->as_s64);
- default:
- abort();
- }
- }
- SCM_OUT_OF_RANGE (SCM_ARG2, index);
- }
- #undef FUNC_NAME
- static const char s_scm_frame_local_set_x[] = "frame-local-set!";
- static SCM
- scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation)
- #define FUNC_NAME s_scm_frame_local_set_x
- {
- union scm_vm_stack_element *fp, *sp;
- unsigned int i;
- enum stack_item_representation repr;
- SCM_VALIDATE_VM_FRAME (1, frame);
- SCM_VALIDATE_UINT_COPY (2, index, i);
- repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3);
- fp = SCM_VM_FRAME_FP (frame);
- sp = SCM_VM_FRAME_SP (frame);
- if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
- {
- union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i);
- switch (repr)
- {
- case STACK_ITEM_SCM:
- item->as_scm = val;
- break;
- case STACK_ITEM_F64:
- item->as_f64 = scm_to_double (val);
- break;
- case STACK_ITEM_U64:
- item->as_u64 = scm_to_uint64 (val);
- break;
- case STACK_ITEM_S64:
- item->as_s64 = scm_to_int64 (val);
- break;
- default:
- abort();
- }
- return SCM_UNSPECIFIED;
- }
- SCM_OUT_OF_RANGE (SCM_ARG2, index);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
- (SCM frame),
- "Return the frame pointer for @var{frame}.")
- #define FUNC_NAME s_scm_frame_address
- {
- SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (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);
- return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_instruction_pointer
- {
- SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_return_address
- {
- SCM_VALIDATE_VM_FRAME (1, 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_dynamic_link, "frame-dynamic-link", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_dynamic_link
- {
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- return scm_from_uintptr_t
- ((scm_t_uintptr)
- 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)
- {
- union scm_vm_stack_element *this_fp, *new_fp, *new_sp;
- union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame);
- again:
- this_fp = stack_top - frame->fp_offset;
- if (this_fp == stack_top)
- return 0;
- new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
- if (new_fp >= stack_top)
- return 0;
- new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
- frame->fp_offset = stack_top - new_fp;
- frame->sp_offset = stack_top - new_sp;
- frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
- if (scm_i_vm_is_boot_continuation_code (frame->ip))
- goto again;
- return 1;
- }
- SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
- (SCM frame),
- "")
- #define FUNC_NAME s_scm_frame_previous
- {
- enum scm_vm_frame_kind kind;
- struct scm_frame tmp;
- SCM_VALIDATE_VM_FRAME (1, frame);
- 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
- static void
- scm_init_frames_builtins (void *unused)
- {
- scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0,
- (scm_t_subr) scm_frame_num_locals);
- scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0,
- (scm_t_subr) scm_frame_local_ref);
- scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0,
- (scm_t_subr) scm_frame_local_set_x);
- }
- void
- scm_init_frames (void)
- {
- #ifndef SCM_MAGIC_SNARFER
- #include "libguile/frames.x"
- #endif
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_frames_builtins",
- scm_init_frames_builtins,
- NULL);
- }
|