123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498 |
- /* Copyright 2001,2009-2015,2018,2021
- Free Software Foundation, Inc.
- This file is part of Guile.
- Guile is free software: you can redistribute it and/or modify it
- under the terms of the GNU Lesser General Public License as published
- by the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
- Guile is distributed in the hope that it will be useful, but WITHOUT
- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
- License for more details.
- You should have received a copy of the GNU Lesser General Public
- License along with Guile. If not, see
- <https://www.gnu.org/licenses/>. */
- #if HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <stdlib.h>
- #include <string.h>
- #include "boolean.h"
- #include "eval.h"
- #include "extensions.h"
- #include "gsubr.h"
- #include "instructions.h"
- #include "modules.h"
- #include "numbers.h"
- #include "pairs.h"
- #include "ports.h"
- #include "symbols.h"
- #include "threads.h"
- #include "variable.h"
- #include "version.h"
- #include "vm.h"
- #include "frames.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 ("#<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 (' ', port);
- scm_write (name, port);
- }
- }
- /* Don't write args, they can be ridiculously long. */
- scm_puts (">", 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 ();
- }
- }
- 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
- /* Scheme interface */
- 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
- /* 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)
- {
- 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,
- STACK_ITEM_PTR = 4
- };
- 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;
- if (scm_is_eq (x, scm_from_latin1_symbol ("ptr")))
- return STACK_ITEM_PTR;
- scm_wrong_type_arg (subr, pos, x);
- return 0; /* Not reached. */
- }
- 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);
- case STACK_ITEM_PTR:
- return scm_from_uintptr_t (item->as_uint);
- 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;
- case STACK_ITEM_PTR:
- item->as_uint = scm_to_uintptr_t (val);
- default:
- abort();
- }
- return SCM_UNSPECIFIED;
- }
- SCM_OUT_OF_RANGE (SCM_ARG2, index);
- }
- #undef FUNC_NAME
- static const char s_scm_frame_return_values[] = "frame-return-values";
- static SCM
- scm_frame_return_values (SCM frame)
- #define FUNC_NAME s_scm_frame_return_values
- {
- const uint32_t *ip;
- union scm_vm_stack_element *fp, *sp;
- SCM vals = SCM_EOL;
- size_t n;
- SCM_VALIDATE_VM_FRAME (1, frame);
- ip = SCM_VM_FRAME_IP (frame);
- fp = SCM_VM_FRAME_FP (frame);
- sp = SCM_VM_FRAME_SP (frame);
- if ((*ip & 0xff) != scm_op_return_values)
- scm_wrong_type_arg_msg (FUNC_NAME, 1, frame, "not a return frame");
- n = SCM_FRAME_NUM_LOCALS (fp, sp);
- while (n--)
- vals = scm_cons (SCM_FRAME_LOCAL (fp, n), vals);
- return vals;
- }
- #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 ((uintptr_t) 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 ((uintptr_t) (SCM_FRAME_VIRTUAL_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);
- /* fixme: munge fp if holder is a continuation */
- return scm_from_uintptr_t
- ((uintptr_t)
- 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_VIRTUAL_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);
- scm_c_define_gsubr (s_scm_frame_return_values, 1, 0, 0,
- (scm_t_subr) scm_frame_return_values);
- }
- void
- scm_init_frames (void)
- {
- #ifndef SCM_MAGIC_SNARFER
- #include "frames.x"
- #endif
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_frames_builtins",
- scm_init_frames_builtins,
- NULL);
- }
|