mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
d5dbe0c1d5
* libguile/vm-i-system.c (wind): * module/language/tree-il/compile-glil.scm (flatten-lambda-case): Instead of making `wind' call `scm_thunk_p' on the winder and unwinder at runtime, make it the responsibility of the compiler to emit code to call thunk? and error, but only if the compiler cannot prove them to be thunks. * libguile/vm-engine.c (vm_engine): Remove a now-unused error block.
313 lines
9.2 KiB
C
313 lines
9.2 KiB
C
/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
|
|
* as published by the Free Software Foundation; either version 3 of
|
|
* the License, or (at your option) any later version.
|
|
*
|
|
* This library 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 this library; if not, write to the Free Software
|
|
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
* 02110-1301 USA
|
|
*/
|
|
|
|
/* This file is included in vm.c multiple times */
|
|
|
|
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
|
|
#define VM_USE_HOOKS 0 /* Various hooks */
|
|
#define VM_CHECK_OBJECT 0 /* Check object table */
|
|
#define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */
|
|
#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
|
|
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
|
|
#define VM_USE_HOOKS 1
|
|
#define VM_CHECK_OBJECT 0
|
|
#define VM_CHECK_FREE_VARIABLES 0
|
|
#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
|
|
#else
|
|
#error unknown debug engine VM_ENGINE
|
|
#endif
|
|
|
|
#include "vm-engine.h"
|
|
|
|
|
|
static SCM
|
|
VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
|
|
{
|
|
/* VM registers */
|
|
register scm_t_uint8 *ip IP_REG; /* instruction pointer */
|
|
register SCM *sp SP_REG; /* stack pointer */
|
|
register SCM *fp FP_REG; /* frame pointer */
|
|
struct scm_vm *vp = SCM_VM_DATA (vm);
|
|
|
|
/* Cache variables */
|
|
struct scm_objcode *bp = NULL; /* program base pointer */
|
|
SCM *objects = NULL; /* constant objects */
|
|
#if VM_CHECK_OBJECT
|
|
size_t object_count = 0; /* length of OBJECTS */
|
|
#endif
|
|
SCM *stack_limit = vp->stack_limit; /* stack limit address */
|
|
|
|
scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
|
|
scm_t_int64 vm_cookie = vp->cookie++;
|
|
|
|
/* Internal variables */
|
|
int nvalues = 0;
|
|
const char *func_name = NULL; /* used for error reporting */
|
|
SCM finish_args; /* used both for returns: both in error
|
|
and normal situations */
|
|
#ifdef HAVE_LABELS_AS_VALUES
|
|
static const void **jump_table_pointer = NULL;
|
|
#endif
|
|
|
|
#ifdef HAVE_LABELS_AS_VALUES
|
|
register const void **jump_table JT_REG;
|
|
|
|
if (SCM_UNLIKELY (!jump_table_pointer))
|
|
{
|
|
int i;
|
|
jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
|
|
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
|
|
jump_table_pointer[i] = &&vm_error_bad_instruction;
|
|
#define VM_INSTRUCTION_TO_LABEL 1
|
|
#define jump_table jump_table_pointer
|
|
#include <libguile/vm-expand.h>
|
|
#include <libguile/vm-i-system.i>
|
|
#include <libguile/vm-i-scheme.i>
|
|
#include <libguile/vm-i-loader.i>
|
|
#undef jump_table
|
|
#undef VM_INSTRUCTION_TO_LABEL
|
|
}
|
|
|
|
/* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
|
|
load instruction at each instruction dispatch. */
|
|
jump_table = jump_table_pointer;
|
|
#endif
|
|
|
|
/* Initialization */
|
|
{
|
|
SCM prog = program;
|
|
|
|
/* Boot program */
|
|
program = vm_make_boot_program (nargs);
|
|
|
|
/* Initial frame */
|
|
CACHE_REGISTER ();
|
|
PUSH (SCM_PACK (fp)); /* dynamic link */
|
|
PUSH (SCM_PACK (0)); /* mvra */
|
|
PUSH (SCM_PACK (ip)); /* ra */
|
|
CACHE_PROGRAM ();
|
|
PUSH (program);
|
|
fp = sp + 1;
|
|
ip = SCM_C_OBJCODE_BASE (bp);
|
|
/* MV-call frame, function & arguments */
|
|
PUSH (SCM_PACK (0)); /* dynamic link */
|
|
PUSH (SCM_PACK (0)); /* mvra */
|
|
PUSH (SCM_PACK (0)); /* ra */
|
|
PUSH (prog);
|
|
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
|
|
goto vm_error_too_many_args;
|
|
while (nargs--)
|
|
PUSH (*argv++);
|
|
}
|
|
|
|
/* Let's go! */
|
|
NEXT;
|
|
|
|
#ifndef HAVE_LABELS_AS_VALUES
|
|
vm_start:
|
|
switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
|
|
#endif
|
|
|
|
#include "vm-expand.h"
|
|
#include "vm-i-system.c"
|
|
#include "vm-i-scheme.c"
|
|
#include "vm-i-loader.c"
|
|
|
|
#ifndef HAVE_LABELS_AS_VALUES
|
|
default:
|
|
goto vm_error_bad_instruction;
|
|
}
|
|
#endif
|
|
|
|
|
|
vm_done:
|
|
SYNC_ALL ();
|
|
return finish_args;
|
|
|
|
/* Errors */
|
|
{
|
|
SCM err_msg;
|
|
|
|
/* FIXME: need to sync regs before allocating anything, in each case. */
|
|
|
|
vm_error_bad_instruction:
|
|
err_msg = scm_from_latin1_string ("VM: Bad instruction: ~s");
|
|
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
|
|
goto vm_error;
|
|
|
|
vm_error_unbound:
|
|
/* FINISH_ARGS should be the name of the unbound variable. */
|
|
SYNC_ALL ();
|
|
err_msg = scm_from_latin1_string ("Unbound variable: ~s");
|
|
scm_error_scm (scm_misc_error_key, program, err_msg,
|
|
scm_list_1 (finish_args), SCM_BOOL_F);
|
|
goto vm_error;
|
|
|
|
vm_error_unbound_fluid:
|
|
SYNC_ALL ();
|
|
err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
|
|
scm_error_scm (scm_misc_error_key, program, err_msg,
|
|
scm_list_1 (finish_args), SCM_BOOL_F);
|
|
goto vm_error;
|
|
|
|
vm_error_not_a_variable:
|
|
SYNC_ALL ();
|
|
scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
|
|
scm_list_1 (finish_args), scm_list_1 (finish_args));
|
|
goto vm_error;
|
|
|
|
vm_error_apply_to_non_list:
|
|
SYNC_ALL ();
|
|
scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
|
|
scm_list_1 (finish_args), scm_list_1 (finish_args));
|
|
goto vm_error;
|
|
|
|
vm_error_kwargs_length_not_even:
|
|
SYNC_ALL ();
|
|
err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
|
|
scm_error_scm (sym_keyword_argument_error, program, err_msg,
|
|
SCM_EOL, SCM_BOOL_F);
|
|
|
|
vm_error_kwargs_invalid_keyword:
|
|
/* FIXME say which one it was */
|
|
SYNC_ALL ();
|
|
err_msg = scm_from_latin1_string ("Invalid keyword");
|
|
scm_error_scm (sym_keyword_argument_error, program, err_msg,
|
|
SCM_EOL, SCM_BOOL_F);
|
|
|
|
vm_error_kwargs_unrecognized_keyword:
|
|
/* FIXME say which one it was */
|
|
SYNC_ALL ();
|
|
err_msg = scm_from_latin1_string ("Unrecognized keyword");
|
|
scm_error_scm (sym_keyword_argument_error, program, err_msg,
|
|
SCM_EOL, SCM_BOOL_F);
|
|
|
|
vm_error_too_many_args:
|
|
err_msg = scm_from_latin1_string ("VM: Too many arguments");
|
|
finish_args = scm_list_1 (scm_from_int (nargs));
|
|
goto vm_error;
|
|
|
|
vm_error_wrong_num_args:
|
|
/* nargs and program are valid */
|
|
SYNC_ALL ();
|
|
scm_wrong_num_args (program);
|
|
/* shouldn't get here */
|
|
goto vm_error;
|
|
|
|
vm_error_wrong_type_apply:
|
|
SYNC_ALL ();
|
|
scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
|
|
scm_list_1 (program), scm_list_1 (program));
|
|
goto vm_error;
|
|
|
|
vm_error_stack_overflow:
|
|
err_msg = scm_from_latin1_string ("VM: Stack overflow");
|
|
finish_args = SCM_EOL;
|
|
if (stack_limit < vp->stack_base + vp->stack_size)
|
|
/* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
|
|
that `throw' below can run on this VM. */
|
|
vp->stack_limit = vp->stack_base + vp->stack_size;
|
|
goto vm_error;
|
|
|
|
vm_error_stack_underflow:
|
|
err_msg = scm_from_latin1_string ("VM: Stack underflow");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
|
|
vm_error_improper_list:
|
|
err_msg = scm_from_latin1_string ("Expected a proper list, but got object with tail ~s");
|
|
goto vm_error;
|
|
|
|
vm_error_not_a_pair:
|
|
SYNC_ALL ();
|
|
scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
|
|
/* shouldn't get here */
|
|
goto vm_error;
|
|
|
|
vm_error_not_a_bytevector:
|
|
SYNC_ALL ();
|
|
scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
|
|
/* shouldn't get here */
|
|
goto vm_error;
|
|
|
|
vm_error_not_a_struct:
|
|
SYNC_ALL ();
|
|
scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
|
|
/* shouldn't get here */
|
|
goto vm_error;
|
|
|
|
vm_error_no_values:
|
|
err_msg = scm_from_latin1_string ("Zero values returned to single-valued continuation");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
|
|
vm_error_not_enough_values:
|
|
err_msg = scm_from_latin1_string ("Too few values returned to continuation");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
|
|
vm_error_continuation_not_rewindable:
|
|
err_msg = scm_from_latin1_string ("Unrewindable partial continuation");
|
|
finish_args = scm_cons (finish_args, SCM_EOL);
|
|
goto vm_error;
|
|
|
|
vm_error_bad_wide_string_length:
|
|
err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S");
|
|
goto vm_error;
|
|
|
|
#ifdef VM_CHECK_IP
|
|
vm_error_invalid_address:
|
|
err_msg = scm_from_latin1_string ("VM: Invalid program address");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
#endif
|
|
|
|
#if VM_CHECK_OBJECT
|
|
vm_error_object:
|
|
err_msg = scm_from_latin1_string ("VM: Invalid object table access");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
#endif
|
|
|
|
#if VM_CHECK_FREE_VARIABLES
|
|
vm_error_free_variable:
|
|
err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
|
|
finish_args = SCM_EOL;
|
|
goto vm_error;
|
|
#endif
|
|
|
|
vm_error:
|
|
SYNC_ALL ();
|
|
|
|
scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
|
|
1);
|
|
}
|
|
|
|
abort (); /* never reached */
|
|
}
|
|
|
|
#undef VM_USE_HOOKS
|
|
#undef VM_CHECK_OBJECT
|
|
#undef VM_CHECK_FREE_VARIABLE
|
|
#undef VM_CHECK_UNDERFLOW
|
|
|
|
/*
|
|
Local Variables:
|
|
c-file-style: "gnu"
|
|
End:
|
|
*/
|