Commit 24dc26f5 authored by eg's avatar eg

VM Modification

The VM doesn't use anymore globals. This is the first step toward
threads integration in STklos
parent 6648278c
/*
This file was automatically generated on Mon Jan 2 10:41:49 2006 by make-C-boot
This file was automatically generated on Sun Jan 22 19:52:02 2006 by make-C-boot
This is a dump of the image in file /mnt/users/eg/Projects/STklos/lib/boot.img3
***DO NOT EDIT BY HAND***
*/
......
No preview for this file type
/*
* l i b . c -- Scheme library
*
* Copyright © 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 7-May-2005 15:50 (eg)
* Last file update: 20-Jan-2006 10:01 (eg)
*/
......@@ -49,7 +49,7 @@ static void init_library_path(void)
int
STk_init_library(int *argc, char ***argv)
STk_init_library(int *argc, char ***argv, int stack_size)
{
STk_get_stack_pointer(&STk_start_stack);
......@@ -74,7 +74,7 @@ STk_init_library(int *argc, char ***argv)
STk_init_boolean() &&
STk_init_reader() &&
STk_init_system() &&
STk_init_vm() &&
STk_init_vm(stack_size) &&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
......
/*
* stklos.c -- STklos interpreter main function
*
* Copyright 1999-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1999-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 21:19 (eg)
* Last file update: 30-Dec-2005 17:06 (eg)
* Last file update: 20-Jan-2006 10:03 (eg)
*/
#include <stklos.h>
......@@ -159,11 +159,8 @@ int main(int argc, char *argv[])
/* Hack: to give the illusion that ther is no VM under the scene */
if (*program_file) argv0 = program_file;
/* Allocate a stack */
STk_allocate_stack(stack_size);
/* Initialize the library */
if (!STk_init_library(&argc, &argv)) {
if (!STk_init_library(&argc, &argv, stack_size)) {
fprintf(stderr, "cannot initialize the STklos library\nABORT\n");
exit(1);
}
......
/*
* stklos.h -- stklos.h
*
* Copyright 1999-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1999-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 26-Dec-2005 18:28 (eg)
* Last file update: 20-Jan-2006 10:06 (eg)
*/
#ifndef STKLOS_H
......@@ -468,7 +468,7 @@ extern int STk_library_initialized; /* True when successfully initialized */
extern char *STk_library_path; /* The base directory where files are found */
extern void *STk_start_stack; /* An approx. of main thread stack addr */
int STk_init_library(int *argc, char ***argv);
int STk_init_library(int *argc, char ***argv, int stack_size);
/*
------------------------------------------------------------------------------
......@@ -1142,15 +1142,13 @@ SCM STk_C_apply(SCM func, int nargs, ...);
void STk_get_stack_pointer(void **addr);
SCM STk_n_values(int n, ...);
void STk_allocate_stack(long n);
EXTERN_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void));
SCM STk_load_bcode_file(SCM f);
int STk_load_boot(char *s);
int STk_boot_from_C(void);
int STk_init_vm(void);
int STk_init_vm(int stack_size);
/*****************************************************************************/
......
/*
* v m . c -- The STklos Virtual Machine
*
* Copyright 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,14 +21,23 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 23-Aug-2005 08:44 (eg)
* Last file update: 22-Jan-2006 19:52 (eg)
*/
// INLINER apply
// INLINER values
// Voir FIX:
#include "stklos.h"
#include "object.h"
#include "vm.h"
#include "vm-instr.h"
#include "struct.h"
#define MAXVALS2 8
/* #define DEBUG_VM */
/* #define STAT_VM */
......@@ -39,7 +48,7 @@ static int cpt_inst[NB_VM_INSTR];
#endif
#ifdef DEBUG_VM
static int debug_level = 0; /* 0 is quiet, 1, 2, ... are more verbose */
static int debug_level = 2; /* 0 is quiet, 1, 2, ... are more verbose */
#endif
......@@ -54,8 +63,8 @@ static int debug_level = 0; /* 0 is quiet, 1, 2, ... are more verbose */
# define NEXT continue;/* Be sure to not use continue elsewhere */
#endif
#define NEXT0 {valc = 0; NEXT;}
#define NEXT1 {valc = 1; NEXT;}
#define NEXT0 {vm->valc = 0; NEXT;}
#define NEXT1 {vm->valc = 1; NEXT;}
#ifdef sparc
......@@ -90,43 +99,57 @@ static Inline void set_signal_mask(sigset_t mask)
*
\*===========================================================================*/
static SCM *stack;
static int stack_len;
/* ==== Stack access macros ==== */
#define push(v) (*(--sp) = (v))
#define pop() (*(sp++))
#define IS_IN_STACKP(a) ((stack <= (SCM*)(a)) && ((SCM*)(a) < &stack[stack_len]))
#define push(v) (*(--(vm->sp)) = (v))
#define pop() (*((vm->sp)++))
//FIX: Optim de la fin
#define IS_IN_STACKP(a) ((vm->stack <= (SCM*)(a)) && \
((SCM*)(a) < &vm->stack[vm->stack_len]))
/* ==== Code access macros ==== */
#define fetch_next() (*pc++)
#define fetch_const() (constants[fetch_next()])
#define fetch_next() (*(vm->pc)++)
#define fetch_const() (vm->constants[fetch_next()])
#define fetch_global() (*(checked_globals[(unsigned) fetch_next()]))
/*===========================================================================*\
*
* V M R E G I S T E R S
* V M T H R E A D
*
\*===========================================================================*/
#define MAX_VALS 8
static STk_instr *pc; /* Program Counter */
static SCM *fp; /* Frame pointer */
static SCM *sp; /* Stack pointer */
static SCM val; /* Current value register */
static SCM env; /* Current environment register */
static SCM *constants; /* Constants of current code */
static SCM *handlers; /* Exceptions handlers */
typedef struct {
STk_instr *pc; /* Program Counter */
SCM *fp; /* Frame pointer */
SCM *sp; /* Stack pointer */
SCM val; /* Current value register */
SCM env; /* Current environment register */
SCM *constants; /* Constants of current code */
SCM *handlers; /* Exceptions handlers */
SCM r1, r2; /* general registers */
SCM vals[MAX_VALS]; /* registers for multiple values */
int valc; /* # of multiple values */
jbuf *top_jmp_buf;
static SCM r1, r2; /* general registers */
SCM *stack;
int stack_len;
} vm_thread_t;
#define MAX_VALS 8
static SCM vals[MAX_VALS]; /* registers for multiple values */
static int valc; /* # of multiple values */
static jbuf *top_jmp_buf = NULL;
static vm_thread_t *the_vm;
vm_thread_t *get_current_vm(void)
{
return the_vm;
}
/*
......@@ -156,26 +179,26 @@ static jbuf *top_jmp_buf = NULL;
#define VM_STATE_JUMP_BUF(reg) ((reg)[4])
#define SAVE_VM_STATE() { \
sp -= VM_STATE_SIZE; \
VM_STATE_PC(sp) = (SCM) pc; \
VM_STATE_CST(sp) = (SCM) constants; \
VM_STATE_ENV(sp) = (SCM) env; \
VM_STATE_FP(sp) = (SCM) fp; \
VM_STATE_JUMP_BUF(sp) = (SCM) top_jmp_buf; \
vm->sp -= VM_STATE_SIZE; \
VM_STATE_PC(vm->sp) = (SCM) vm->pc; \
VM_STATE_CST(vm->sp) = (SCM) vm->constants; \
VM_STATE_ENV(vm->sp) = (SCM) vm->env; \
VM_STATE_FP(vm->sp) = (SCM) vm->fp; \
VM_STATE_JUMP_BUF(vm->sp) = (SCM) vm->top_jmp_buf; \
}
#define FULL_RESTORE_VM_STATE(p) { \
pc = (STk_instr *) VM_STATE_PC(p); \
vm->pc = (STk_instr *) VM_STATE_PC(p); \
RESTORE_VM_STATE(p); \
}
#define RESTORE_VM_STATE(p) { \
/* pc is not restored here. See FULL_RESTORE_VM_STATE */ \
constants = (SCM *) VM_STATE_CST(p); \
env = (SCM) VM_STATE_ENV(p); \
fp = (SCM *) VM_STATE_FP(p); \
top_jmp_buf = (jbuf *) VM_STATE_JUMP_BUF(p); \
sp += VM_STATE_SIZE; \
vm->constants = (SCM *) VM_STATE_CST(p); \
vm->env = (SCM) VM_STATE_ENV(p); \
vm->fp = (SCM *) VM_STATE_FP(p); \
vm->top_jmp_buf = (jbuf *) VM_STATE_JUMP_BUF(p); \
vm->sp += VM_STATE_SIZE; \
}
......@@ -191,18 +214,18 @@ static jbuf *top_jmp_buf = NULL;
#define SAVE_HANDLER_STATE(proc, addr) { \
sp -= EXCEPTION_HANDLER_SIZE; \
HANDLER_PROC(sp) = (SCM) (proc); \
HANDLER_END(sp) = (SCM) (addr); \
HANDLER_PREV(sp) = (SCM) handlers; \
handlers = sp; \
vm->sp -= EXCEPTION_HANDLER_SIZE; \
HANDLER_PROC(vm->sp) = (SCM) (proc); \
HANDLER_END(vm->sp) = (SCM) (addr); \
HANDLER_PREV(vm->sp) = (SCM) vm->handlers; \
vm->handlers = vm->sp; \
}
#define UNSAVE_HANDLER_STATE() { \
SCM *old = handlers; \
SCM *old = vm->handlers; \
\
handlers = (SCM *) HANDLER_PREV(handlers); \
sp = old + EXCEPTION_HANDLER_SIZE; \
vm->handlers = (SCM *) HANDLER_PREV(vm->handlers); \
vm->sp = old + EXCEPTION_HANDLER_SIZE; \
}
......@@ -213,24 +236,24 @@ static jbuf *top_jmp_buf = NULL;
\*===========================================================================*/
#define PREP_CALL() { \
SCM fp_save = (SCM) fp; \
SCM fp_save = (SCM)(vm->fp); \
\
/* Push an activation record on the stack */ \
sp -= ACT_RECORD_SIZE; \
fp = sp; \
ACT_SAVE_FP(fp) = fp_save; \
ACT_SAVE_PROC(fp) = STk_false; \
ACT_SAVE_INFO(fp) = STk_false; \
vm->sp -= ACT_RECORD_SIZE; \
vm->fp = vm->sp; \
ACT_SAVE_FP(vm->fp) = fp_save; \
ACT_SAVE_PROC(vm->fp) = STk_false; \
ACT_SAVE_INFO(vm->fp) = STk_false; \
/* Other fields will be initialized later */ \
}
#define RET_CALL() { \
sp = fp + ACT_RECORD_SIZE; \
env = ACT_SAVE_ENV(fp); \
pc = ACT_SAVE_PC(fp); \
constants = ACT_SAVE_CST(fp); \
fp = ACT_SAVE_FP(fp); \
vm->sp = vm->fp + ACT_RECORD_SIZE; \
vm->env = ACT_SAVE_ENV(vm->fp); \
vm->pc = ACT_SAVE_PC(vm->fp); \
vm->constants = ACT_SAVE_CST(vm->fp); \
vm->fp = ACT_SAVE_FP(vm->fp); \
}
......@@ -251,32 +274,32 @@ static int checked_globals_used = 0;
#define PUSH_ENV(nargs, func, next_env) { \
BOXED_TYPE(sp) = tc_frame; \
FRAME_LENGTH(sp) = nargs; \
FRAME_NEXT(sp) = next_env; \
FRAME_OWNER(sp) = func; \
BOXED_TYPE(vm->sp) = tc_frame; \
FRAME_LENGTH(vm->sp) = nargs; \
FRAME_NEXT(vm->sp) = next_env; \
FRAME_OWNER(vm->sp) = func; \
}
#define CALL_CLOSURE(func) { \
pc = CLOSURE_BCODE(func); \
constants = CLOSURE_CONST(func); \
env = (SCM) sp; \
vm->pc = CLOSURE_BCODE(func); \
vm->constants = CLOSURE_CONST(func); \
vm->env = (SCM) vm->sp; \
}
#define CALL_PRIM(v, args) { \
ACT_SAVE_PROC(fp) = v; \
ACT_SAVE_PROC(vm->fp) = v; \
v = PRIMITIVE_FUNC(v)args; \
}
#define REG_CALL_PRIM(name) { \
extern SCM CPP_CONCAT(STk_o_, name)(); \
ACT_SAVE_PROC(fp) = CPP_CONCAT(STk_o_, name); \
#define REG_CALL_PRIM(name) { \
extern SCM CPP_CONCAT(STk_o_, name)(); \
ACT_SAVE_PROC(vm->fp) = CPP_CONCAT(STk_o_, name); \
}
#define RETURN_FROM_PRIMITIVE() { \
sp = fp + ACT_RECORD_SIZE; \
fp = (SCM *) ACT_SAVE_FP(fp); \
vm->sp = vm->fp + ACT_RECORD_SIZE; \
vm->fp = (SCM *) ACT_SAVE_FP(vm->fp); \
}
static void run_vm(STk_instr *code, SCM *constants, SCM envt);
......@@ -291,43 +314,46 @@ static void run_vm(STk_instr *code, SCM *constants, SCM envt);
#ifdef DEBUG_VM
void STk_print_vm_registers(char *msg, STk_instr *code)
{
if (IS_IN_STACKP(env))
vm_thread_t *vm = get_current_vm();
if (IS_IN_STACKP(vm->env))
STk_fprintf(STk_stderr, "%s VAL=~S PC=%d SP=%d FP=%d CST=%x ENV=%x (%d)\n",
msg, val, pc-code, sp-stack, fp-stack, constants, env,
(SCM*)env-stack);
msg, vm->val, vm->pc - code, vm->sp - vm->stack,
vm->fp - vm->stack, vm->constants, vm->env,
(SCM*)vm->env - vm->stack);
else
STk_fprintf(STk_stderr, "%s VAL=~S PC=%d SP=%d FP=%d CST=%x ENV=%x (%d)",
msg, val, pc-code, sp-stack, fp-stack, constants, env,
(SCM*)env-stack);
msg, vm->val, vm->pc - code, vm->sp - vm->stack,
vm->fp - vm->stack, vm->constants, vm->env,
(SCM*)vm->env - vm->stack);
}
#endif
static Inline SCM listify_top(int n)
static Inline SCM listify_top(int n, vm_thread_t *vm)
{
SCM *p, res = STk_nil;
for (p = sp, sp+=n; p < sp; p++)
for (p = vm->sp, vm->sp+=n; p < vm->sp; p++)
res = STk_cons(*p, res);
return res;
}
static Inline SCM clone_env(SCM e)
static Inline SCM clone_env(SCM e, vm_thread_t *vm)
{
/* clone environment til we find one which is in the heap */
if (FRAMEP(e) && IS_IN_STACKP(e)) {
e = STk_clone_frame(e);
FRAME_NEXT(e) = clone_env((SCM) FRAME_NEXT(e));
FRAME_NEXT(e) = clone_env((SCM) FRAME_NEXT(e), vm);
}
return e;
}
static void error_bad_arity(SCM func, int arity, short given_args, SCM *fp)
static void error_bad_arity(SCM func, int arity, short given_args, vm_thread_t *vm)
{
ACT_SAVE_PROC(fp) = func;
ACT_SAVE_PROC(vm->fp) = func;
if (arity >= 0)
STk_error("%d argument%s required in call to ~S (%d provided)",
arity, ((arity>1)? "s": ""), func, given_args);
......@@ -337,18 +363,18 @@ static void error_bad_arity(SCM func, int arity, short given_args, SCM *fp)
}
static Inline short adjust_arity(SCM func, short nargs, SCM *fp)
static Inline short adjust_arity(SCM func, short nargs, vm_thread_t *vm)
{
short arity = CLOSURE_ARITY(func);
if (arity != nargs) {
if (arity >= 0)
error_bad_arity(func, arity, nargs, fp);
error_bad_arity(func, arity, nargs, vm);
else { /* nary procedure call */
short min_arity = -arity-1;
if (nargs < min_arity)
error_bad_arity(func, arity, nargs, fp);
error_bad_arity(func, arity, nargs, vm);
else { /* Make a list from the arguments which are on the stack. */
SCM res = STk_nil;
......@@ -404,7 +430,7 @@ static int add_global(SCM *ref)
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("apply", scheme_apply, apply, (int argc))
DEFINE_PRIMITIVE("apply", scheme_apply, apply, (int argc, vm_thread_t *vm))
{
SCM l, func, *tmp, *argv;
int len, nargs;
......@@ -412,12 +438,12 @@ DEFINE_PRIMITIVE("apply", scheme_apply, apply, (int argc))
if (argc == 0) STk_error("no function given");
nargs = argc - 1;
argv = sp + nargs;
argv = vm->sp + nargs;
func = *argv;
if (nargs > 0) {
/* look at last argument */
l = *sp;
l = *vm->sp;
len = STk_int_length(l);
if (len < 0)
......@@ -425,10 +451,10 @@ DEFINE_PRIMITIVE("apply", scheme_apply, apply, (int argc))
else {
/* move all the arguments, except the last one, one cell lower in the
* stack (i.e. overwrite the function to call) */
for (tmp = argv-1; tmp > sp; tmp--)
for (tmp = argv-1; tmp > vm->sp; tmp--)
*(tmp+1) = *tmp;
sp = tmp + 2;
vm->sp = tmp + 2;
if (len != 0) {
/* Unfold the last argument in place */
while (!NULLP(l)) {
......@@ -441,8 +467,8 @@ DEFINE_PRIMITIVE("apply", scheme_apply, apply, (int argc))
}
/* Place the function to apply and its number of arguments in R1 and R2 */
r1 = func;
r2 = AS_SCM(nargs);
vm->r1 = func;
vm->r2 = AS_SCM(nargs);
return STk_apply_call;
}
......@@ -467,6 +493,7 @@ SCM STk_C_apply(SCM func, int nargs, ...)
{
static STk_instr code[]= {INVOKE, 0, END_OF_CODE};
va_list ap;
vm_thread_t *vm = get_current_vm();
int i;
va_start(ap, nargs);
......@@ -486,13 +513,13 @@ SCM STk_C_apply(SCM func, int nargs, ...)
for (i = 0; i < nargs; i++) push(va_arg(ap, SCM));
}
val = func; /* Store fun in VAL */
vm->val = func; /* Store fun in VAL */
code[1] = (short) nargs; /* Patch # of args */
run_vm(code, constants, env);
FULL_RESTORE_VM_STATE(sp);
run_vm(code, vm->constants, vm->env);
FULL_RESTORE_VM_STATE(vm->sp);
return val;
return vm->val;
}
......@@ -500,6 +527,7 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
{
int i, len;
STk_instr *vinstr, *p;
vm_thread_t *vm = get_current_vm();
if (!envt) envt = STk_current_module;
......@@ -516,9 +544,9 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
SAVE_VM_STATE();
run_vm(vinstr, VECTOR_DATA(consts), envt);
FULL_RESTORE_VM_STATE(sp);
FULL_RESTORE_VM_STATE(vm->sp);
return val;
return vm->val;
}
......@@ -541,27 +569,28 @@ doc>
*/
DEFINE_PRIMITIVE("values", values, vsubr, (int argc, SCM *argv))
{
vm_thread_t *vm = get_current_vm();
int i;
if (argc == 0)
val = STk_void;
vm->val = STk_void;
else {
val = argv[0];
vm->val = argv[0];
if (argc <= MAX_VALS) {
for (i = 1; i < argc; i++)
vals[i] = argv[-i];
vm->vals[i] = argv[-i];
} else {
/* More than MAX_VALS values. Use a vector and store it in vals[0] */
SCM tmp = STk_makevect(argc, (SCM) NULL);
for (i = 0; i < argc; i++) VECTOR_DATA(tmp)[i] = *argv--;
vals[0] = tmp;
vm->vals[0] = tmp;
}
}
/* Retain in valc the number of values */
valc = argc;
return val;
vm->valc = argc;
return vm->val;
}
/*
......@@ -582,52 +611,55 @@ doc>
*/
DEFINE_PRIMITIVE("call-with-values", call_with_values, subr2, (SCM prod, SCM con))
{
vm_thread_t *vm = get_current_vm();
int tmp;
if (!STk_procedurep(prod)) STk_error("bad producer", prod);
if (!STk_procedurep(con)) STk_error("bad consumer", con);
val = STk_C_apply(prod, 0);
tmp = valc;
vm->val = STk_C_apply(prod, 0);
tmp = vm->valc;
if (tmp == 0)
return STk_C_apply(con, 0);
else if (tmp == 1)
return STk_C_apply(con, 1, val);
return STk_C_apply(con, 1, vm->val);
else if (tmp <= MAX_VALS) {
vals[0] = val;
return STk_C_apply(con , -tmp, vals);
vm->vals[0] = vm->val;
return STk_C_apply(con , -tmp, vm->vals);
} else {
return STk_C_apply(con, -tmp, VECTOR_DATA(vals[0]));
return STk_C_apply(con, -tmp, VECTOR_DATA(vm->vals[0]));
}
}
SCM STk_n_values(int n, ...)
{
valc = n;
vm_thread_t *vm = get_current_vm();
vm->valc = n;
if (!n)
val = STk_void;
vm->val = STk_void;
else {
va_list ap;
int i;
va_start(ap, n);
val = va_arg(ap, SCM);
vm->val = va_arg(ap, SCM);
if (n <= MAX_VALS) {
for (i = 1; i < n; i++)
vals[i] = va_arg(ap, SCM);
vm->vals[i] = va_arg(ap, SCM);
} else {
/* More than MAX_VALS values. Use a vector and store it in vals[0] */
SCM tmp = STk_makevect(n, (SCM) NULL);
for (i = 0; i < n; i++) VECTOR_DATA(tmp)[i] = va_arg(ap, SCM);
vals[0] = tmp;
vm->vals[0] = tmp;
}
}
return val;
return vm->val;
}
/*===========================================================================*\
......@@ -641,12 +673,12 @@ SCM STk_n_values(int n, ...)
* the number of elements used on the stack
*/
static void vm_debug(int kind, SCM *fp)
static void vm_debug(int kind, vm_thread_t *vm)
{
switch (kind) {
case 0: /* old trace code position. Don't use it anymode */
{
SCM line = val;
SCM line = vm->val;
SCM file = pop();
STk_panic("Recompile code in file ~S (contains obsolete line informations)",
file, line);
......@@ -654,9 +686,9 @@ static void vm_debug(int kind, SCM *fp)
}
case 1: /* Embed line information in a procedure call */
{
SCM line = val;
SCM line = vm->val;
ACT_SAVE_INFO(fp) = STk_cons(pop(), line);
ACT_SAVE_INFO(vm->fp) = STk_cons(pop(), line);
break;
}
}
......@@ -665,9 +697,10 @@ static void vm_debug(int kind, SCM *fp)
DEFINE_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void))
{
SCM res, *lfp;
vm_thread_t *vm = get_current_vm();
res = STk_nil;
for (lfp = fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
for (lfp = vm->fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
SCM self = (SCM) (ACT_SAVE_PROC(lfp));
if (!self) break;
......@@ -709,7 +742,7 @@ DEFINE_PRIMITIVE("%vm", set_vm_debug, vsubr, (int argc, SCM *argv))
* This function is just a placeholder for debugging the VM. It's body is
* changed depending of the current bug to track
*/
return STk_void;
}
#endif
......@@ -723,6 +756,7 @@ DEFINE_PRIMITIVE("%vm", set_vm_debug, vsubr, (int argc, SCM *argv))
static void run_vm(STk_instr *code, SCM *consts, SCM envt)
{
vm_thread_t *vm = get_current_vm();
jbuf jb;
jbuf *old_jb = NULL; /* to make Gcc happy */
short offset, nargs=0;
......@@ -742,9 +776,9 @@ static void run_vm(STk_instr *code, SCM *consts, SCM envt)
static short previous_op = NOP;
#endif
constants = consts;
env = envt;
pc = code;
vm->constants = consts;
vm->env = envt;
vm->pc = code;
#if defined(USE_COMPUTED_GOTO)
......@@ -756,9 +790,11 @@ static void run_vm(STk_instr *code, SCM *consts, SCM envt)
# ifdef DEBUG_VM
if (debug_level > 1)
fprintf(stderr, "%08x [%03d]: %20s sp=%-6d fp=%-6d env=%x\n",
pc - 1,
pc-code_base-1,
name_table[(int)byteop], sp-stack, fp-stack, (int) env);
vm->pc - 1,
vm->pc - code_base-1,
name_table[(int)byteop],
vm->sp - vm->stack,
vm->fp - vm->stack, (int) vm->env);
# ifdef STAT_VM
couple_instr[previous_op][byteop]++;
cpt_inst[byteop]++;
......@@ -772,77 +808,81 @@ static void run_vm(STk_instr *code, SCM *consts, SCM envt)
CASE(NOP) { NEXT; }
CASE(IM_FALSE) { val = STk_false; NEXT1;}
CASE(IM_TRUE) { val = STk_true; NEXT1;}
CASE(IM_NIL) { val = STk_nil; NEXT1;}
CASE(IM_MINUS1) { val = MAKE_INT(-1); NEXT1;}
CASE(IM_ZERO) { val = MAKE_INT(0); NEXT1;}
CASE(IM_ONE) { val = MAKE_INT(1); NEXT1;}
CASE(IM_VOID) { val = STk_void; NEXT1;}
CASE(IM_FALSE) { vm->val = STk_false; NEXT1;}
CASE(IM_TRUE) { vm->val = STk_true; NEXT1;}
CASE(IM_NIL) { vm->val = STk_nil; NEXT1;}
CASE(IM_MINUS1) { vm->val = MAKE_INT(-1); NEXT1;}
CASE(IM_ZERO) { vm->val = MAKE_INT(0); NEXT1;}
CASE(IM_ONE) { vm->val = MAKE_INT(1); NEXT1;}
CASE(IM_VOID) { vm->val = STk_void; NEXT1;}