mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-06 00:17:39 +00:00
parent bd098a1a93
commit 3d5ee0cdcc
10 changed files with 189 additions and 186 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/system/repl/command.gs
View file

@ -281,20 +281,15 @@ Generate compiled code.
-e Stop after expanding syntax/macro
-t Stop after translating into GHIL
-c Stop after generating GLIL
-l Stop before linking
-o Compile into bytecode
-O Enable optimization
-D Add debug information"
(let ((x (apply repl-compile repl form opts)))
(cond ((null? opts)
(puts x))
((memq :l opts)
(disassemble-bytecode x))
((memq :c opts)
(pprint-glil x))
(else
(puts x)))))
(else (puts x)))))
(define (compile-file repl file . opts)
"compile-file [options] FILE

28
module/system/vm/assemble.scm
View file

@ -41,7 +41,7 @@
(define-structure (venv parent nexts closure?))
(define-structure (vmod id))
(define-structure (vlink module name))
(define-structure (bytespec nargs nrest nlocs bytes objs))
(define-structure (bytespec nargs nrest nlocs nexts bytes objs))
;;;
@ -146,11 +146,10 @@
(error "Unknown instruction:" inst)))))
;;
;; main
(if (> nexts 0) (push-code! `(external ,nexts)))
(for-each generate-code body)
(let ((bytes (apply string-append (stack-finalize (reverse! stack))))
(objs (map car (reverse! object-alist))))
(make-bytespec nargs nrest nlocs bytes objs))))))
(make-bytespec nargs nrest nlocs nexts bytes objs))))))
(define (stack-finalize stack)
(let loop ((list '()) (stack stack) (addr 0))
@ -208,16 +207,25 @@
(let ((nargs (bytespec-nargs x))
(nrest (bytespec-nrest x))
(nlocs (bytespec-nlocs x))
(nexts (bytespec-nexts x))
(bytes (bytespec-bytes x))
(objs (bytespec-objs x)))
;; dump parameters
(if (and (< nargs 4) (< nlocs 16))
(push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
(begin
(push-code! (object->code nargs))
(push-code! (object->code nrest))
(push-code! (object->code nlocs))
(push-code! (object->code #f))))
(cond ((and (< nargs 4) (< nlocs 8) (< nexts 4))
;; 8-bit representation
(let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
(push-code! `(make-int8 ,x))))
((and (< nargs 16) (< nlocs 128) (< nexts 16))
;; 16-bit representation
(let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
(else
;; Other cases
(push-code! (object->code nargs))
(push-code! (object->code nrest))
(push-code! (object->code nlocs))
(push-code! (object->code nexts))
(push-code! (object->code #f))))
;; dump object table
(cond ((not (null? objs))
(for-each dump! objs)

6
src/programs.c
View file

@ -58,13 +58,14 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
p->nargs = 0;
p->nrest = 0;
p->nlocs = 0;
p->nexts = 0;
p->meta = SCM_EOL;
p->objs = zero_vector;
p->external = SCM_EOL;
p->holder = holder;
/* If nobody holds bytecode's address, then allocate a new memory */
if (SCM_FALSEP (p->holder))
if (SCM_FALSEP (holder))
p->base = SCM_MUST_MALLOC (size);
else
p->base = addr;
@ -74,7 +75,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
#undef FUNC_NAME
SCM
scm_c_make_vclosure (SCM program, SCM external)
scm_c_make_closure (SCM program, SCM external)
{
struct scm_program *p;
struct scm_program *q = SCM_PROGRAM_DATA (program);
@ -83,6 +84,7 @@ scm_c_make_vclosure (SCM program, SCM external)
p->nargs = q->nargs;
p->nrest = q->nrest;
p->nlocs = q->nlocs;
p->nexts = q->nexts;
p->meta = q->meta;
p->objs = q->objs;
p->external = external;

8
src/programs.h
View file

@ -54,8 +54,9 @@ typedef unsigned char scm_byte_t;
struct scm_program {
size_t size; /* the size of the program */
unsigned char nargs; /* the number of arguments */
unsigned char nrest; /* have a rest argument or not */
unsigned short nlocs; /* the number of local variables */
unsigned char nrest; /* the number of rest argument (0 or 1) */
unsigned char nlocs; /* the number of local variables */
unsigned char nexts; /* the number of external variables */
scm_byte_t *base; /* program base address */
SCM meta; /* meta information */
SCM objs; /* constant objects */
@ -73,6 +74,7 @@ extern scm_bits_t scm_tc16_program;
#define SCM_PROGRAM_NARGS(x) (SCM_PROGRAM_DATA (x)->nargs)
#define SCM_PROGRAM_NREST(x) (SCM_PROGRAM_DATA (x)->nrest)
#define SCM_PROGRAM_NLOCS(x) (SCM_PROGRAM_DATA (x)->nlocs)
#define SCM_PROGRAM_NEXTS(x) (SCM_PROGRAM_DATA (x)->nexts)
#define SCM_PROGRAM_BASE(x) (SCM_PROGRAM_DATA (x)->base)
#define SCM_PROGRAM_META(x) (SCM_PROGRAM_DATA (x)->meta)
#define SCM_PROGRAM_OBJS(x) (SCM_PROGRAM_DATA (x)->objs)
@ -81,7 +83,7 @@ extern scm_bits_t scm_tc16_program;
#define SCM_PROGRAM_HOLDER(x) (SCM_PROGRAM_DATA (x)->holder)
extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
extern SCM scm_c_make_vclosure (SCM program, SCM external);
extern SCM scm_c_make_closure (SCM program, SCM external);
extern void scm_init_programs (void);

88
src/vm.c
View file

@ -139,44 +139,44 @@ scm_bits_t scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
static SCM
capture_vm_cont (struct scm_vm *vmp)
capture_vm_cont (struct scm_vm *vp)
{
struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
p->stack_size = vmp->stack_limit - vmp->sp;
p->stack_size = vp->stack_limit - vp->sp;
p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
p->stack_limit = p->stack_base + p->stack_size - 2;
p->ip = vmp->ip;
p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
p->ip = vp->ip;
p->sp = (SCM *) (vp->stack_limit - vp->sp);
p->fp = (SCM *) (vp->stack_limit - vp->fp);
memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
}
static void
reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
reinstate_vm_cont (struct scm_vm *vp, SCM cont)
{
struct scm_vm *p = SCM_VM_CONT_VMP (cont);
if (vmp->stack_size < p->stack_size)
struct scm_vm *p = SCM_VM_CONT_VP (cont);
if (vp->stack_size < p->stack_size)
{
/* puts ("FIXME: Need to expand"); */
abort ();
}
vmp->ip = p->ip;
vmp->sp = vmp->stack_limit - (int) p->sp;
vmp->fp = vmp->stack_limit - (int) p->fp;
memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
vp->ip = p->ip;
vp->sp = vp->stack_limit - (int) p->sp;
vp->fp = vp->stack_limit - (int) p->fp;
memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
}
static SCM
vm_cont_mark (SCM obj)
{
SCM *p;
struct scm_vm *vmp = SCM_VM_CONT_VMP (obj);
for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
struct scm_vm *vp = SCM_VM_CONT_VP (obj);
for (p = vp->stack_base; p <= vp->stack_limit; p++)
if (SCM_NIMP (*p))
scm_gc_mark (*p);
return SCM_BOOL_F;
@ -185,7 +185,7 @@ vm_cont_mark (SCM obj)
static scm_sizet
vm_cont_free (SCM obj)
{
struct scm_vm *p = SCM_VM_CONT_VMP (obj);
struct scm_vm *p = SCM_VM_CONT_VP (obj);
int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
scm_must_free (p->stack_base);
scm_must_free (p);
@ -255,20 +255,20 @@ make_vm (void)
#define FUNC_NAME "make_vm"
{
int i;
struct scm_vm *vmp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
vmp->stack_size = VM_DEFAULT_STACK_SIZE;
vmp->stack_base = SCM_MUST_MALLOC (vmp->stack_size * sizeof (SCM));
vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
vmp->ip = NULL;
vmp->sp = vmp->stack_limit;
vmp->fp = NULL;
vmp->cons = 0;
vmp->time = 0;
vmp->clock = 0;
vmp->options = SCM_EOL;
struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
vp->stack_size = VM_DEFAULT_STACK_SIZE;
vp->stack_base = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
vp->stack_limit = vp->stack_base + vp->stack_size - 1;
vp->ip = NULL;
vp->sp = vp->stack_limit;
vp->fp = NULL;
vp->cons = 0;
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vmp->hooks[i] = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vmp);
vp->hooks[i] = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
}
#undef FUNC_NAME
@ -277,11 +277,11 @@ vm_mark (SCM obj)
{
int i;
SCM *sp, *fp;
struct scm_vm *vmp = SCM_VM_DATA (obj);
struct scm_vm *vp = SCM_VM_DATA (obj);
/* Mark the stack */
sp = vmp->sp;
fp = vmp->fp;
sp = vp->sp;
fp = vp->fp;
while (fp)
{
SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
@ -301,17 +301,17 @@ vm_mark (SCM obj)
/* Mark the options */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vmp->hooks[i]);
return vmp->options;
scm_gc_mark (vp->hooks[i]);
return vp->options;
}
static scm_sizet
vm_free (SCM obj)
{
struct scm_vm *vmp = SCM_VM_DATA (obj);
int size = (sizeof (struct scm_vm) + vmp->stack_size * sizeof (SCM));
scm_must_free (vmp->stack_base);
scm_must_free (vmp);
struct scm_vm *vp = SCM_VM_DATA (obj);
int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM));
scm_must_free (vp->stack_base);
scm_must_free (vp);
return size;
}
@ -387,12 +387,12 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
#define VM_DEFINE_HOOK(n) \
{ \
struct scm_vm *vmp; \
struct scm_vm *vp; \
SCM_VALIDATE_VM (1, vm); \
vmp = SCM_VM_DATA (vm); \
if (SCM_FALSEP (vmp->hooks[n])) \
vmp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \
return vmp->hooks[n]; \
vp = SCM_VM_DATA (vm); \
if (SCM_FALSEP (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \
return vp->hooks[n]; \
}
SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,

8
src/vm.h
View file

@ -61,16 +61,16 @@
*/
/*
| | <- fp + bp->nargs + bp->nlocs
+------------------+
| | <- fp + bp->nlocs + bp->nargs
+------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp)
| Argument 1 |
| Argument 2 |
| Argument 2 | <- fp + bp->nlocs
| Local variable 1 |
| Local varialbe 2 | <- fp
| Program |
| Dynamic link |
| Return address | <- fp - SCM_VM_FRAME_DATA_SIZE
+------------------+
+------------------+ = SCM_VM_FRAME_LOWER_ADDRESS (fp)
| |
*/

35
src/vm_engine.c
View file

@ -53,16 +53,16 @@ vm_engine (SCM vm, SCM program, SCM args)
register SCM *fp FP_REG; /* frame pointer */
/* Cache variables */
struct scm_vm *vmp = SCM_VM_DATA (vm);/* VM data pointer */
struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */
struct scm_program *bp = NULL; /* program base pointer */
SCM external; /* external environment */
SCM *objects = NULL; /* constant objects */
SCM *stack_base = vmp->stack_base; /* stack base address */
SCM *stack_limit = vmp->stack_limit; /* stack limit address */
SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
/* Internal variables */
int nargs = 0;
long run_time = scm_c_get_internal_run_time ();
long start_time = scm_c_get_internal_run_time ();
// SCM dynwinds = SCM_EOL;
SCM err_msg;
SCM err_args;
@ -83,20 +83,23 @@ vm_engine (SCM vm, SCM program, SCM args)
};
#endif
/* Bootcode */
scm_byte_t code[3] = {scm_op_call, 0, scm_op_halt};
SCM bootcode = scm_c_make_program (code, 3, SCM_BOOL_T);
code[1] = scm_ilength (args);
/* Initialization */
{
/* Bootcode */
scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
SCM bootcode = scm_c_make_program (bytes, 3, SCM_BOOL_T);
bytes[1] = scm_ilength (args);
/* Initial frame */
bp = SCM_PROGRAM_DATA (bootcode);
CACHE ();
NEW_FRAME ();
/* Initial frame */
CACHE_REGISTER ();
CACHE_PROGRAM (bootcode);
NEW_FRAME ();
/* Initial arguments */
for (; !SCM_NULLP (args); args = SCM_CDR (args))
PUSH (SCM_CAR (args));
PUSH (program);
/* Initial arguments */
for (; !SCM_NULLP (args); args = SCM_CDR (args))
PUSH (SCM_CAR (args));
PUSH (program);
}
/* Let's go! */
BOOT_HOOK ();

122
src/vm_engine.h
View file

@ -42,14 +42,11 @@
/* This file is included in vm_engine.c */
/*
* VM Options
* Options
*/
#define VM_OPTION(regular,debug) debug
#define VM_USE_HOOKS VM_OPTION (0, 1) /* Various hooks */
#define VM_USE_CLOCK VM_OPTION (0, 1) /* Bogos clock */
#define VM_CHECK_IP VM_OPTION (0, 0) /* Check IP */
#define VM_USE_HOOKS 1 /* Various hooks */
#define VM_USE_CLOCK 1 /* Bogoclock */
/*
@ -113,6 +110,42 @@
#endif
#endif
/*
* Cache/Sync
*/
#define CACHE_REGISTER() \
{ \
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
}
#define SYNC_REGISTER() \
{ \
vp->ip = ip; \
vp->sp = sp; \
vp->fp = fp; \
}
#define CACHE_PROGRAM(program) \
{ \
bp = SCM_PROGRAM_DATA (program); \
objects = SCM_VELTS (bp->objs); \
external = bp->external; \
}
#define SYNC_BEFORE_GC() \
{ \
SYNC_REGISTER (); \
}
#define SYNC_ALL() \
{ \
SYNC_REGISTER (); \
}
/*
* Hooks
@ -124,7 +157,7 @@
{ \
if (!SCM_FALSEP (h)) \
{ \
SYNC (); \
SYNC_BEFORE_GC (); \
scm_c_run_hook (h, hook_args); \
} \
}
@ -132,45 +165,13 @@
#define RUN_HOOK(h)
#endif
#define BOOT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_BOOT_HOOK])
#define HALT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_HALT_HOOK])
#define NEXT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_NEXT_HOOK])
#define ENTER_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_ENTER_HOOK])
#define APPLY_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_APPLY_HOOK])
#define EXIT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_EXIT_HOOK])
#define RETURN_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_RETURN_HOOK])
/*
* Basic operations
*/
#define CACHE() \
{ \
ip = vmp->ip; \
sp = vmp->sp; \
fp = vmp->fp; \
}
#define SYNC() \
{ \
vmp->ip = ip; \
vmp->sp = sp; \
vmp->fp = fp; \
}
#define SYNC_TIME() \
{ \
long cur_time = scm_c_get_internal_run_time (); \
vmp->time += cur_time - run_time; \
run_time = cur_time; \
}
#define SYNC_ALL() \
{ \
SYNC (); \
SYNC_TIME (); \
}
#define BOOT_HOOK() RUN_HOOK (vp->hooks[SCM_VM_BOOT_HOOK])
#define HALT_HOOK() RUN_HOOK (vp->hooks[SCM_VM_HALT_HOOK])
#define NEXT_HOOK() RUN_HOOK (vp->hooks[SCM_VM_NEXT_HOOK])
#define ENTER_HOOK() RUN_HOOK (vp->hooks[SCM_VM_ENTER_HOOK])
#define APPLY_HOOK() RUN_HOOK (vp->hooks[SCM_VM_APPLY_HOOK])
#define EXIT_HOOK() RUN_HOOK (vp->hooks[SCM_VM_EXIT_HOOK])
#define RETURN_HOOK() RUN_HOOK (vp->hooks[SCM_VM_RETURN_HOOK])
/*
@ -192,7 +193,7 @@
#define CONS(x,y,z) \
{ \
SCM cell; \
SYNC () \
SYNC_BEFORE_GC (); \
SCM_NEWCELL (cell); \
SCM_SET_CELL_OBJECT_0 (cell, y); \
SCM_SET_CELL_OBJECT_1 (cell, z); \
@ -219,23 +220,11 @@ do { \
#undef CLOCK
#if VM_USE_CLOCK
#define CLOCK(n) vmp->clock += n
#define CLOCK(n) vp->clock += n
#else
#define CLOCK(n)
#endif
#undef NEXT_CHECK
#if VM_CHECK_IP
#define NEXT_CHECK() \
{ \
scm_byte_t *base = bp->base; \
if (ip < base || ip >= base + bp->size) \
goto vm_error_invalid_address; \
}
#else
#define NEXT_CHECK()
#endif
#undef NEXT_JUMP
#ifdef HAVE_LABELS_AS_VALUES
#define NEXT_JUMP() goto *jump_table[FETCH ()]
@ -246,7 +235,6 @@ do { \
#define NEXT \
{ \
CLOCK (1); \
NEXT_CHECK (); \
NEXT_HOOK (); \
NEXT_JUMP (); \
}
@ -304,18 +292,6 @@ do { \
} \
}
#define INIT_VARIABLES() \
{ \
int i; \
for (i = 0; i < bp->nlocs; i++) \
SCM_VM_FRAME_VARIABLE (fp, i) = SCM_UNDEFINED; \
}
#define CACHE_PROGRAM() \
bp = SCM_PROGRAM_DATA (program); \
objects = SCM_VELTS (bp->objs); \
external = bp->external;
/*
Local Variables:
c-file-style: "gnu"

29
src/vm_loader.c
View file

@ -118,16 +118,31 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
if (SCM_INUMP (x))
{
int i = SCM_INUM (x);
SCM_PROGRAM_NARGS (prog) = i >> 5; /* 6-5 bits */
SCM_PROGRAM_NREST (prog) = (i >> 4) & 1; /* 4 bit */
SCM_PROGRAM_NLOCS (prog) = i & 15; /* 3-0 bits */
if (-128 <= i && i <= 127)
{
/* 8-bit representation */
SCM_PROGRAM_NARGS (prog) = (i >> 6) & 0x03; /* 7-6 bits */
SCM_PROGRAM_NREST (prog) = (i >> 5) & 0x01; /* 5 bit */
SCM_PROGRAM_NLOCS (prog) = (i >> 2) & 0x07; /* 4-2 bits */
SCM_PROGRAM_NEXTS (prog) = i & 0x03; /* 1-0 bits */
}
else
{
/* 16-bit representation */
SCM_PROGRAM_NARGS (prog) = (i >> 12) & 0x07; /* 15-12 bits */
SCM_PROGRAM_NREST (prog) = (i >> 11) & 0x01; /* 11 bit */
SCM_PROGRAM_NLOCS (prog) = (i >> 4) & 0x7f; /* 10-4 bits */
SCM_PROGRAM_NEXTS (prog) = i & 0x07; /* 3-0 bits */
}
}
else
{
SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[3]);
SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[1]);
sp += 3;
/* Other cases */
SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[4]);
SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[3]);
SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[2]);
SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[1]);
sp += 4;
}
*sp = prog;

44
src/vm_system.c
View file

@ -55,6 +55,7 @@ VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
{
SCM ret = *sp;
vp->time += scm_c_get_internal_run_time () - start_time;
HALT_HOOK ();
FREE_FRAME ();
SYNC_ALL ();
@ -154,14 +155,6 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
#define VARIABLE_REF(v) SCM_CDR (v)
#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
VM_DEFINE_INSTRUCTION (external, "external", 1, 0, 0)
{
int n = FETCH ();
while (n-- > 0)
CONS (external, SCM_UNDEFINED, external);
NEXT;
}
/* ref */
VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
@ -284,8 +277,8 @@ VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
{
SYNC ();
*sp = scm_c_make_vclosure (*sp, external);
SYNC_BEFORE_GC ();
*sp = scm_c_make_closure (*sp, external);
NEXT;
}
@ -300,10 +293,20 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
*/
if (SCM_PROGRAM_P (program))
{
CACHE_PROGRAM ();
int i;
vm_call_program:
CACHE_PROGRAM (program);
INIT_ARGS ();
NEW_FRAME ();
INIT_VARIABLES ();
/* Init local variables */
for (i = 0; i < bp->nlocs; i++)
LOCAL_SET (i, SCM_UNDEFINED);
/* Create external variables */
for (i = 0; i < bp->nexts; i++)
CONS (external, SCM_UNDEFINED, external);
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@ -330,8 +333,8 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
/* Reinstate the continuation */
EXIT_HOOK ();
reinstate_vm_cont (vmp, program);
CACHE ();
reinstate_vm_cont (vp, program);
CACHE_REGISTER ();
/* We don't need to set the return value here
because it is already on the top of the stack. */
NEXT;
@ -376,7 +379,6 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
if (SCM_PROGRAM_P (program))
{
int i;
int n = SCM_VM_FRAME_LOWER_ADDRESS (fp) - sp;
SCM *base = sp;
/* Exit the current frame */
@ -384,12 +386,12 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
FREE_FRAME ();
/* Move arguments */
sp -= n;
for (i = 0; i < n; i++)
sp -= nargs;
for (i = 0; i < nargs; i++)
sp[i] = base[i];
/* Call the program */
goto vm_call;
goto vm_call_program;
}
/*
* Function call
@ -412,8 +414,8 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
{
SYNC ();
PUSH (capture_vm_cont (vmp));
SYNC_BEFORE_GC ();
PUSH (capture_vm_cont (vp));
POP (program);
nargs = 1;
goto vm_call;
@ -430,7 +432,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
/* Cache the last program */
program = SCM_VM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
CACHE_PROGRAM (program);
PUSH (ret);
NEXT;
}