summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/frames.c11
-rw-r--r--libguile/instructions.c63
-rw-r--r--libguile/instructions.h30
-rw-r--r--libguile/objcodes.c165
-rw-r--r--libguile/objcodes.h30
-rw-r--r--libguile/procs.c1
-rw-r--r--libguile/programs.c151
-rw-r--r--libguile/programs.h25
-rw-r--r--libguile/stacks.c4
-rw-r--r--libguile/vm-engine.c43
-rw-r--r--libguile/vm-engine.h14
-rw-r--r--libguile/vm-expand.h28
-rw-r--r--libguile/vm-i-loader.c137
-rw-r--r--libguile/vm-i-scheme.c69
-rw-r--r--libguile/vm-i-system.c175
-rw-r--r--libguile/vm.c44
16 files changed, 454 insertions, 536 deletions
diff --git a/libguile/frames.c b/libguile/frames.c
index fa1c54f59..baa62a744 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -108,7 +108,7 @@ SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
{
SCM *fp;
int i;
- struct scm_program *bp;
+ struct scm_objcode *bp;
SCM ret;
SCM_VALIDATE_VM_FRAME (1, frame);
@@ -136,14 +136,15 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
#define FUNC_NAME s_scm_vm_frame_source
{
SCM *fp;
- struct scm_program *bp;
+ struct scm_objcode *bp;
SCM_VALIDATE_VM_FRAME (1, frame);
fp = SCM_VM_FRAME_FP (frame);
bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
- return scm_c_program_source (bp, SCM_VM_FRAME_IP (frame) - bp->base);
+ return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
+ SCM_VM_FRAME_IP (frame) - bp->base);
}
#undef FUNC_NAME
@@ -154,7 +155,7 @@ SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
{
SCM *fp;
unsigned int i;
- struct scm_program *bp;
+ struct scm_objcode *bp;
SCM_VALIDATE_VM_FRAME (1, frame);
@@ -175,7 +176,7 @@ SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
{
SCM *fp;
unsigned int i;
- struct scm_program *bp;
+ struct scm_objcode *bp;
SCM_VALIDATE_VM_FRAME (1, frame);
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 89b6c774b..be92a8420 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -47,7 +47,19 @@
#include "vm-bootstrap.h"
#include "instructions.h"
-struct scm_instruction scm_instruction_table[] = {
+struct scm_instruction {
+ enum scm_opcode opcode; /* opcode */
+ const char *name; /* instruction name */
+ signed char len; /* Instruction length. This may be -1 for
+ the loader (see the `VM_LOADER'
+ macro). */
+ signed char npop; /* The number of values popped. This may be
+ -1 for insns like `call' which can take
+ any number of arguments. */
+ char npush; /* the number of values pushed */
+};
+
+static struct scm_instruction scm_instruction_table[] = {
#define VM_INSTRUCTION_TO_TABLE 1
#include "vm-expand.h"
#include "vm-i-system.i"
@@ -57,10 +69,15 @@ struct scm_instruction scm_instruction_table[] = {
{scm_op_last}
};
-/* C interface */
+#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar) \
+ do { \
+ cvar = scm_lookup_instruction_by_name (var); \
+ SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P"); \
+ } while (0)
-struct scm_instruction *
-scm_lookup_instruction (SCM name)
+
+static struct scm_instruction *
+scm_lookup_instruction_by_name (SCM name)
{
struct scm_instruction *ip;
char *symbol;
@@ -82,6 +99,7 @@ scm_lookup_instruction (SCM name)
return 0;
}
+
/* Scheme interface */
SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
@@ -102,7 +120,7 @@ SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_p
{
- return SCM_BOOL (SCM_INSTRUCTION_P (obj));
+ return SCM_BOOL (scm_lookup_instruction_by_name (obj));
}
#undef FUNC_NAME
@@ -111,8 +129,9 @@ SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_length
{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_I_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->len);
}
#undef FUNC_NAME
@@ -121,8 +140,9 @@ SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_pops
{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_I_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->npop);
}
#undef FUNC_NAME
@@ -131,8 +151,9 @@ SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_pushes
{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_I_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->npush);
}
#undef FUNC_NAME
@@ -141,8 +162,9 @@ SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
"")
#define FUNC_NAME s_scm_instruction_to_opcode
{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_I_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+ struct scm_instruction *ip;
+ SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+ return SCM_I_MAKINUM (ip->opcode);
}
#undef FUNC_NAME
@@ -151,11 +173,18 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
"")
#define FUNC_NAME s_scm_opcode_to_instruction
{
- int i;
+ struct scm_instruction *ip;
+ int opcode;
+
SCM_MAKE_VALIDATE (1, op, I_INUMP);
- i = SCM_I_INUM (op);
- SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
- return scm_from_locale_symbol (scm_instruction_table[i].name);
+ opcode = SCM_I_INUM (op);
+
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ if (opcode == ip->opcode)
+ return scm_from_locale_symbol (ip->name);
+
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
+ return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 1a965daf9..5de45ad9c 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -44,6 +44,9 @@
#include <libguile.h>
+#define SCM_VM_NUM_INSTRUCTIONS (1<<7)
+#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
+
enum scm_opcode {
#define VM_INSTRUCTION_TO_OPCODE 1
#include "vm-expand.h"
@@ -51,34 +54,9 @@ enum scm_opcode {
#include "vm-i-scheme.i"
#include "vm-i-loader.i"
#undef VM_INSTRUCTION_TO_OPCODE
- scm_op_last
-};
-
-struct scm_instruction {
- enum scm_opcode opcode; /* opcode */
- const char *name; /* instruction name */
- signed char len; /* Instruction length. This may be -1 for
- the loader (see the `VM_LOADER'
- macro). */
- signed char npop; /* The number of values popped. This may be
- -1 for insns like `call' which can take
- any number of arguments. */
- char npush; /* the number of values pushed */
+ scm_op_last = SCM_VM_NUM_INSTRUCTIONS
};
-#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x))
-#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode)
-#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name)
-#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len)
-#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop)
-#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush)
-#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
-
-#define SCM_INSTRUCTION(i) (&scm_instruction_table[i])
-
-extern struct scm_instruction scm_instruction_table[];
-extern struct scm_instruction *scm_lookup_instruction (SCM name);
-
extern SCM scm_instruction_list (void);
extern SCM scm_instruction_p (SCM obj);
extern SCM scm_instruction_length (SCM inst);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 10782d443..7ef47b66c 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -55,6 +55,7 @@
#include "programs.h"
#include "objcodes.h"
+/* nb, the length of the header should be a multiple of 8 bytes */
#define OBJCODE_COOKIE "GOOF-0.5"
@@ -65,32 +66,20 @@
scm_t_bits scm_tc16_objcode;
static SCM
-make_objcode (size_t size)
-#define FUNC_NAME "make_objcode"
-{
- struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
- "objcode");
- p->size = size;
- p->base = scm_gc_malloc (size, "objcode-base");
- p->fd = -1;
- SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
-}
-#undef FUNC_NAME
-
-static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
{
int ret;
char *addr;
struct stat st;
- struct scm_objcode *p;
+ SCM sret = SCM_BOOL_F;
+ struct scm_objcode *data;
ret = fstat (fd, &st);
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= strlen (OBJCODE_COOKIE))
+ if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
@@ -101,38 +90,56 @@ make_objcode_by_mmap (int fd)
if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
SCM_SYSERROR;
- p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
- p->size = st.st_size;
- p->base = addr;
- p->fd = fd;
- SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+ data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+
+ if (data->len != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ SCM_LIST2 (scm_from_size_t (st.st_size),
+ scm_from_uint32 (data->len)));
+
+ SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+ SCM_PACK (SCM_BOOL_F), fd);
+ SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+
+ /* FIXME: we leak ourselves and the file descriptor. but then again so does
+ dlopen(). */
+ return scm_permanent_object (sret);
}
#undef FUNC_NAME
-static scm_sizet
-objcode_free (SCM obj)
-#define FUNC_NAME "objcode_free"
+SCM
+scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
{
- size_t size = sizeof (struct scm_objcode);
- struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
-
- if (p->fd >= 0)
- {
- int rv;
- rv = munmap (p->base, p->size);
- if (rv < 0) SCM_SYSERROR;
- rv = close (p->fd);
- if (rv < 0) SCM_SYSERROR;
- }
- else
- scm_gc_free (p->base, p->size, "objcode-base");
-
- scm_gc_free (p, size, "objcode");
-
- return 0;
+ struct scm_objcode *data, *parent_data;
+ SCM ret;
+
+ SCM_VALIDATE_OBJCODE (1, parent);
+ parent_data = SCM_OBJCODE_DATA (parent);
+
+ if (ptr < parent_data->base
+ || ptr >= (parent_data->base + parent_data->len
+ - sizeof (struct scm_objcode)))
+ scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a)",
+ SCM_LIST2 (scm_from_ulong ((ulong)ptr),
+ scm_from_uint32 (parent_data->len)));
+
+ data = (struct scm_objcode*)ptr;
+ if (data->base + data->len > parent_data->base + parent_data->len)
+ abort ();
+
+ SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
+ SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
+ return ret;
}
#undef FUNC_NAME
+static SCM
+objcode_mark (SCM obj)
+{
+ return SCM_SMOB_OBJECT_2 (obj);
+}
+
/*
* Scheme interface
@@ -147,38 +154,32 @@ SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
- (SCM bytecode, SCM nlocs, SCM nexts),
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+ (SCM bytecode),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
ssize_t increment;
scm_t_array_handle handle;
- char *base;
const scm_t_uint8 *c_bytecode;
+ struct scm_objcode *data;
SCM objcode;
- if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+ if (scm_is_false (scm_u8vector_p (bytecode)))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- SCM_VALIDATE_NUMBER (2, nlocs);
- SCM_VALIDATE_NUMBER (3, nexts);
c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
- assert (increment == 1);
-
- /* Account for the 10 byte-long header. */
- size += 10;
- objcode = make_objcode (size);
- base = SCM_OBJCODE_BASE (objcode);
-
- memcpy (base, OBJCODE_COOKIE, 8);
- base[8] = scm_to_uint8 (nlocs);
- base[9] = scm_to_uint8 (nexts);
-
- memcpy (base + 10, c_bytecode, size - 10);
-
+ data = (struct scm_objcode*)c_bytecode;
+ SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
scm_array_handle_release (&handle);
+ assert (increment == 1);
+ SCM_ASSERT_RANGE (0, bytecode, size < 1<<31);
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(*data));
+ SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
+
+ /* foolishly, we assume that as long as bytecode is around, that c_bytecode
+ will be of the same length; perhaps a bad assumption? */
return objcode;
}
@@ -209,43 +210,32 @@ SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
#define FUNC_NAME s_scm_objcode_to_u8vector
{
scm_t_uint8 *u8vector;
- size_t size;
+ scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
- size = SCM_OBJCODE_SIZE (objcode);
+ len = SCM_OBJCODE_DATA (objcode)->len + sizeof(struct scm_objcode);
/* FIXME: Is `gc_malloc' ok here? */
- u8vector = scm_gc_malloc (size, "objcode-u8vector");
- memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+ u8vector = scm_gc_malloc (len, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, size);
+ return scm_take_u8vector (u8vector, len);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 1, 0,
- (SCM objcode, SCM external),
+SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
+ (SCM objcode, SCM port),
"")
-#define FUNC_NAME s_scm_objcode_to_program
+#define FUNC_NAME s_scm_write_objcode
{
- SCM prog;
- size_t size;
- char *base;
- struct scm_program *p;
-
SCM_VALIDATE_OBJCODE (1, objcode);
- if (SCM_UNBNDP (external))
- external = SCM_EOL;
- else
- SCM_VALIDATE_LIST (2, external);
-
- base = SCM_OBJCODE_BASE (objcode);
- size = SCM_OBJCODE_SIZE (objcode);
- prog = scm_c_make_program (base + 10, size - 10, SCM_BOOL_F, objcode);
- p = SCM_PROGRAM_DATA (prog);
- p->nlocs = base[8];
- p->nexts = base[9];
- p->external = external;
- return prog;
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+
+ scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_DATA (objcode),
+ SCM_OBJCODE_LEN (objcode) + sizeof (struct scm_objcode));
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -254,7 +244,7 @@ void
scm_bootstrap_objcodes (void)
{
scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_set_smob_free (scm_tc16_objcode, objcode_free);
+ scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
}
void
@@ -265,6 +255,9 @@ scm_init_objcodes (void)
#ifndef SCM_MAGIC_SNARFER
#include "objcodes.x"
#endif
+
+ scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
+ scm_c_define ("byte-order", scm_from_uint16 (__BYTE_ORDER));
}
/*
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 5e4808b4c..60ec0e64c 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -44,27 +44,43 @@
#include <libguile.h>
+/* objcode data should be directly mappable to this C structure. */
struct scm_objcode {
- size_t size; /* objcode size */
- char *base; /* objcode base address */
- int fd; /* file descriptor when mmap'ed */
+ scm_t_uint8 nargs;
+ scm_t_uint8 nrest;
+ scm_t_uint8 nlocs;
+ scm_t_uint8 nexts;
+ scm_t_uint32 len; /* the maximum index of base[] */
+ scm_t_uint8 base[0];
};
+#define SCM_F_OBJCODE_IS_MMAP (1<<0)
+#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+
extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
-#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size)
+#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
+#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
+#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
+#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
+#define SCM_OBJCODE_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
-#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd)
+#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+
+SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
extern SCM scm_load_objcode (SCM file);
-extern SCM scm_objcode_to_program (SCM objcode, SCM external);
extern SCM scm_objcode_p (SCM obj);
-extern SCM scm_bytecode_to_objcode (SCM bytecode, SCM nlocs, SCM nexts);
+extern SCM scm_bytecode_to_objcode (SCM bytecode);
extern SCM scm_objcode_to_u8vector (SCM objcode);
+extern SCM scm_write_objcode (SCM objcode, SCM port);
extern void scm_bootstrap_objcodes (void);
extern void scm_init_objcodes (void);
diff --git a/libguile/procs.c b/libguile/procs.c
index e417cca07..edf398a04 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -32,6 +32,7 @@
#include "libguile/validate.h"
#include "libguile/procs.h"
#include "libguile/procprop.h"
+#include "libguile/objcodes.h"
#include "libguile/programs.h"
diff --git a/libguile/programs.c b/libguile/programs.c
index f5b5d42ba..e9c093a2e 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -53,71 +53,35 @@
scm_t_bits scm_tc16_program;
-static SCM zero_vector;
static SCM write_program = SCM_BOOL_F;
-SCM
-scm_c_make_program (void *addr, size_t size, SCM objs, SCM holder)
-#define FUNC_NAME "scm_c_make_program"
+SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
+ (SCM objcode, SCM objtable, SCM external),
+ "")
+#define FUNC_NAME s_scm_make_program
{
- struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
- "program");
- p->size = size;
- p->nargs = 0;
- p->nrest = 0;
- p->nlocs = 0;
- p->nexts = 0;
- p->objs = objs;
- p->external = SCM_EOL;
- p->holder = holder;
-
- /* If nobody holds bytecode's address, then allocate a new memory */
- if (SCM_FALSEP (holder))
- {
- p->base = scm_gc_malloc (size, "program-base");
- memcpy (p->base, addr, size);
- }
+ SCM_VALIDATE_OBJCODE (1, objcode);
+ if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
+ objtable = SCM_BOOL_F;
+ else if (scm_is_true (objtable))
+ SCM_VALIDATE_VECTOR (2, objtable);
+ if (SCM_UNLIKELY (SCM_UNBNDP (external)))
+ external = SCM_EOL;
else
- p->base = addr;
+ SCM_VALIDATE_LIST (3, external);
- SCM_RETURN_NEWSMOB (scm_tc16_program, p);
+ SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
}
#undef FUNC_NAME
-SCM
-scm_c_make_closure (SCM program, SCM external)
-{
- struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
- "program");
- *p = *SCM_PROGRAM_DATA (program);
- p->holder = program;
- p->external = external;
- SCM_RETURN_NEWSMOB (scm_tc16_program, p);
-}
-
static SCM
program_mark (SCM obj)
{
- struct scm_program *p = SCM_PROGRAM_DATA (obj);
- if (scm_is_true (p->objs))
- scm_gc_mark (p->objs);
- if (!scm_is_null (p->external))
- scm_gc_mark (p->external);
- return p->holder;
-}
-
-static scm_sizet
-program_free (SCM obj)
-{
- struct scm_program *p = SCM_PROGRAM_DATA (obj);
- scm_sizet size = (sizeof (struct scm_program));
-
- if (SCM_FALSEP (p->holder))
- scm_gc_free (p->base, p->size, "program-base");
-
- scm_gc_free (p, size, "program");
-
- return 0;
+ if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
+ scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
+ if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
+ scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
+ return SCM_PROGRAM_OBJCODE (obj);
}
static SCM
@@ -175,7 +139,7 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
"")
#define FUNC_NAME s_scm_program_arity
{
- struct scm_program *p;
+ struct scm_objcode *p;
SCM_VALIDATE_PROGRAM (1, program);
@@ -187,6 +151,28 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_objects
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_OBJTABLE (program);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_module
+{
+ SCM objs;
+ SCM_VALIDATE_PROGRAM (1, program);
+ objs = SCM_PROGRAM_OBJTABLE (program);
+ return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
(SCM program),
"")
@@ -194,19 +180,17 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
{
SCM objs;
SCM_VALIDATE_PROGRAM (1, program);
- objs = SCM_PROGRAM_DATA (program)->objs;
+ objs = SCM_PROGRAM_OBJTABLE (program);
return scm_is_true (objs) ? scm_c_vector_ref (objs, 1) : SCM_BOOL_F;
}
#undef FUNC_NAME
extern SCM
-scm_c_program_source (struct scm_program *p, size_t ip)
+scm_c_program_source (SCM program, size_t ip)
{
SCM meta, sources, source;
- if (scm_is_false (p->objs))
- return SCM_BOOL_F;
- meta = scm_c_vector_ref (p->objs, 1);
+ meta = scm_program_meta (program);
if (scm_is_false (meta))
return SCM_BOOL_F;
meta = scm_call_0 (meta);
@@ -220,35 +204,13 @@ scm_c_program_source (struct scm_program *p, size_t ip)
return scm_cdr (source); /* a #(line column file) vector */
}
-SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_objects
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_DATA (program)->objs;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_module
-{
- SCM objs;
- SCM_VALIDATE_PROGRAM (1, program);
- objs = SCM_PROGRAM_DATA (program)->objs;
- return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_external
{
SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_DATA (program)->external;
+ return SCM_PROGRAM_EXTERNALS (program);
}
#undef FUNC_NAME
@@ -260,29 +222,19 @@ SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
{
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_LIST (2, external);
- SCM_PROGRAM_DATA (program)->external = external;
+ SCM_PROGRAM_EXTERNALS (program) = external;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
+SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
(SCM program),
- "Return a u8vector containing @var{program}'s bytecode.")
-#define FUNC_NAME s_scm_program_bytecode
+ "Return a @var{program}'s object code.")
+#define FUNC_NAME s_scm_program_objcode
{
- size_t size;
- scm_t_uint8 *c_bytecode;
-
SCM_VALIDATE_PROGRAM (1, program);
- size = SCM_PROGRAM_DATA (program)->size;
- c_bytecode = malloc (size);
- if (!c_bytecode)
- return SCM_BOOL_F;
-
- memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size);
-
- return scm_take_u8vector (c_bytecode, size);
+ return SCM_PROGRAM_OBJCODE (program);
}
#undef FUNC_NAME
@@ -291,11 +243,8 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
void
scm_bootstrap_programs (void)
{
- zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
-
scm_tc16_program = scm_make_smob_type ("program", 0);
scm_set_smob_mark (scm_tc16_program, program_mark);
- scm_set_smob_free (scm_tc16_program, program_free);
scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
scm_set_smob_print (scm_tc16_program, program_print);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index 4b5447fb8..024ca1926 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -43,6 +43,7 @@
#define _SCM_PROGRAMS_H_
#include <libguile.h>
+#include <libguile/objcodes.h>
/*
* Programs
@@ -50,26 +51,16 @@
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; /* 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 objs; /* constant objects */
- SCM external; /* external environment */
- SCM holder; /* the owner of bytecode */
-};
-
extern scm_t_bits scm_tc16_program;
#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
-#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x))
+#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
+#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
+#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-extern SCM scm_c_make_program (void *addr, size_t size, SCM objs, SCM holder);
-extern SCM scm_c_make_closure (SCM program, SCM external);
+extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
extern SCM scm_program_p (SCM obj);
extern SCM scm_program_base (SCM program);
@@ -79,9 +70,9 @@ extern SCM scm_program_objects (SCM program);
extern SCM scm_program_module (SCM program);
extern SCM scm_program_external (SCM program);
extern SCM scm_program_external_set_x (SCM program, SCM external);
-extern SCM scm_program_bytecode (SCM program);
+extern SCM scm_program_objcode (SCM program);
-extern SCM scm_c_program_source (struct scm_program *p, size_t ip);
+extern SCM scm_c_program_source (SCM program, size_t ip);
extern void scm_bootstrap_programs (void);
extern void scm_init_programs (void);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index e3d131d12..cef01e475 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -129,8 +129,8 @@
/* FIXME: factor this out somewhere? */
static int is_vm_bootstrap_frame (SCM f)
{
- struct scm_program *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
- return bp->base[bp->size-1] == scm_op_halt;
+ struct scm_objcode *bp = SCM_PROGRAM_DATA (scm_vm_frame_program (f));
+ return bp->base[bp->len-1] == scm_op_halt;
}
/* Count number of debug info frames on a stack, beginning with
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2f058c5b8..e1468b61d 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -55,7 +55,7 @@ vm_run (SCM vm, SCM program, SCM args)
/* Cache variables */
struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */
- struct scm_program *bp = NULL; /* program base pointer */
+ struct scm_objcode *bp = NULL; /* program base pointer */
SCM external = SCM_EOL; /* external environment */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
@@ -74,6 +74,25 @@ vm_run (SCM vm, SCM program, SCM args)
#endif
struct vm_unwind_data wind_data;
+#ifdef HAVE_LABELS_AS_VALUES
+ static void **jump_table = NULL;
+
+ if (SCM_UNLIKELY (!jump_table))
+ {
+ int i;
+ jump_table = scm_gc_malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*),
+ "jump table");
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+ jump_table[i] = &&vm_error_bad_instruction;
+#define VM_INSTRUCTION_TO_LABEL 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_LABEL
+ }
+#endif
+
/* dynwind ended in the halt instruction */
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
wind_data.vp = vp;
@@ -87,18 +106,6 @@ vm_run (SCM vm, SCM program, SCM args)
scm_dynwind_fluid (scm_the_vm_fluid, vm);
*/
-#ifdef HAVE_LABELS_AS_VALUES
- /* Jump table */
- static void *jump_table[] = {
-#define VM_INSTRUCTION_TO_LABEL 1
-#include "vm-expand.h"
-#include "vm-i-system.i"
-#include "vm-i-scheme.i"
-#include "vm-i-loader.i"
-#undef VM_INSTRUCTION_TO_LABEL
- };
-#endif
-
/* Initialization */
{
SCM prog = program;
@@ -120,10 +127,11 @@ vm_run (SCM vm, SCM program, SCM args)
/* Let's go! */
BOOT_HOOK ();
+ NEXT;
#ifndef HAVE_LABELS_AS_VALUES
vm_start:
- switch (*ip++) {
+ switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
#endif
#include "vm-expand.h"
@@ -132,11 +140,18 @@ vm_run (SCM vm, SCM program, SCM args)
#include "vm-i-loader.c"
#ifndef HAVE_LABELS_AS_VALUES
+ default:
+ goto vm_error_bad_instruction;
}
#endif
/* Errors */
{
+ vm_error_bad_instruction:
+ err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
+ err_args = SCM_LIST1 (scm_from_uchar (ip[-1]));
+ goto vm_error;
+
vm_error_unbound:
err_msg = scm_from_locale_string ("VM: Unbound variable: ~A");
goto vm_error;
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index eef9ee6d4..221bef064 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -151,7 +151,7 @@
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
- do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0)
+ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
#else
#define CHECK_IP()
#endif
@@ -165,9 +165,9 @@
{ \
if (bp != SCM_PROGRAM_DATA (program)) { \
bp = SCM_PROGRAM_DATA (program); \
- if (SCM_I_IS_VECTOR (bp->objs)) { \
- objects = SCM_I_VECTOR_WELTS (bp->objs); \
- object_count = SCM_I_VECTOR_LENGTH (bp->objs); \
+ if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
+ objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
+ object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
} else { \
objects = NULL; \
object_count = 0; \
@@ -341,7 +341,7 @@ do { \
*/
#define FETCH() (*ip++)
-#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
+#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
#undef CLOCK
#if VM_USE_CLOCK
@@ -352,7 +352,7 @@ do { \
#undef NEXT_JUMP
#ifdef HAVE_LABELS_AS_VALUES
-#define NEXT_JUMP() goto *jump_table[FETCH ()]
+#define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
#else
#define NEXT_JUMP() goto vm_start
#endif
@@ -423,7 +423,7 @@ do { \
want the stack marker to see the data \
array formatted as expected. */ \
data[0] = SCM_UNDEFINED; \
- external = bp->external; \
+ external = SCM_PROGRAM_EXTERNALS (fp[-1]); \
for (i = 0; i < bp->nexts; i++) \
CONS (external, SCM_UNDEFINED, external); \
data[0] = external; \
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
index cccb56b9f..d750a73d8 100644
--- a/libguile/vm-expand.h
+++ b/libguile/vm-expand.h
@@ -57,13 +57,13 @@
#undef VM_DEFINE_LOADER
#ifdef VM_INSTRUCTION_TO_TABLE
/*
- * These will go to scm_instruction_table in vm.c
+ * These will go to scm_instruction_table in instructions.c
*/
-#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) \
{VM_OPCODE (tag), name, len, npop, npush},
-#define VM_DEFINE_FUNCTION(tag,name,nargs) \
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) \
{VM_OPCODE (tag), name, 0, nargs, 1},
-#define VM_DEFINE_LOADER(tag,name) \
+#define VM_DEFINE_LOADER(code,tag,name) \
{VM_OPCODE (tag), name, -1, 0, 1},
#else
@@ -71,26 +71,26 @@
/*
* These will go to jump_table in vm_engine.c
*/
-#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag),
-#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
-#define VM_DEFINE_LOADER(tag,name) VM_ADDR (tag),
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) jump_table[VM_OPCODE (tag)] = VM_ADDR (tag);
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) jump_table[VM_OPCODE (tag)] = VM_ADDR (tag);
+#define VM_DEFINE_LOADER(code,tag,name) jump_table[VM_OPCODE (tag)] = VM_ADDR (tag);
#else
#ifdef VM_INSTRUCTION_TO_OPCODE
/*
- * These will go to scm_opcode in vm.h
+ * These will go to scm_opcode in instructions.h
*/
-#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag),
-#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
-#define VM_DEFINE_LOADER(tag,name) VM_OPCODE (tag),
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_OPCODE (tag) = code,
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) VM_OPCODE (tag) = code,
+#define VM_DEFINE_LOADER(code,tag,name) VM_OPCODE (tag) = code,
#else /* Otherwise */
/*
* These are directly included in vm_engine.c
*/
-#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag)
-#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
-#define VM_DEFINE_LOADER(tag,name) VM_TAG (tag)
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_TAG (tag)
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) VM_TAG (tag)
+#define VM_DEFINE_LOADER(code,tag,name) VM_TAG (tag)
#endif /* VM_INSTRUCTION_TO_OPCODE */
#endif /* VM_INSTRUCTION_TO_LABEL */
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 45aced1de..2919638bc 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,65 +1,42 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
+/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * 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 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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_engine.c */
-VM_DEFINE_LOADER (load_integer, "load-integer")
+VM_DEFINE_LOADER (60, load_integer, "load-integer")
{
size_t len;
FETCH_LENGTH (len);
if (len <= 4)
{
- long val = 0;
+ int val = 0;
while (len-- > 0)
val = (val << 8) + FETCH ();
SYNC_REGISTER ();
- PUSH (scm_from_ulong (val));
+ PUSH (scm_from_int (val));
NEXT;
}
else
SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
}
-VM_DEFINE_LOADER (load_number, "load-number")
+VM_DEFINE_LOADER (61, load_number, "load-number")
{
size_t len;
@@ -72,7 +49,7 @@ VM_DEFINE_LOADER (load_number, "load-number")
NEXT;
}
-VM_DEFINE_LOADER (load_string, "load-string")
+VM_DEFINE_LOADER (62, load_string, "load-string")
{
size_t len;
FETCH_LENGTH (len);
@@ -83,7 +60,7 @@ VM_DEFINE_LOADER (load_string, "load-string")
NEXT;
}
-VM_DEFINE_LOADER (load_symbol, "load-symbol")
+VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
@@ -93,7 +70,7 @@ VM_DEFINE_LOADER (load_symbol, "load-symbol")
NEXT;
}
-VM_DEFINE_LOADER (load_keyword, "load-keyword")
+VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
{
size_t len;
FETCH_LENGTH (len);
@@ -103,62 +80,28 @@ VM_DEFINE_LOADER (load_keyword, "load-keyword")
NEXT;
}
-VM_DEFINE_LOADER (load_program, "load-program")
+VM_DEFINE_LOADER (65, load_program, "load-program")
{
- size_t len;
- SCM prog, x, objs = SCM_BOOL_F, meta = SCM_BOOL_F;
- struct scm_program *p;
+ scm_t_uint32 len;
+ SCM objs, objcode;
- POP (x);
+ POP (objs);
+ SYNC_REGISTER ();
- /* init meta data */
- if (SCM_PROGRAM_P (x))
- {
- meta = x;
- POP (x);
- }
+ if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
+ scm_c_vector_set_x (objs, 0, scm_current_module ());
- /* init object table */
- if (scm_is_vector (x))
- {
- objs = x;
- scm_c_vector_set_x (objs, 0, scm_current_module ());
- scm_c_vector_set_x (objs, 1, meta);
- POP (x);
- }
+ objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
+ len = sizeof (struct scm_objcode) + SCM_OBJCODE_LEN (objcode);
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- prog = scm_c_make_program (ip, len, objs, program);
- p = SCM_PROGRAM_DATA (prog);
- ip += len;
+ PUSH (scm_make_program (objcode, objs, SCM_EOL));
- /* init parameters */
- /* NOTE: format defined in system/vm/assemble.scm */
- if (SCM_I_INUMP (x))
- {
- scm_t_uint16 s = (scm_t_uint16)SCM_I_INUM (x);
- /* 16-bit representation */
- p->nargs = (s >> 12) & 0x0f; /* 15-12 bits */
- p->nrest = (s >> 11) & 0x01; /* 11 bit */
- p->nlocs = (s >> 4) & 0x7f; /* 10-04 bits */
- p->nexts = s & 0x0f; /* 03-00 bits */
- }
- else
- {
- /* Other cases */
- /* x is #f, and already popped off */
- POP (x); p->nexts = scm_to_unsigned_integer (x, 0, 255);
- POP (x); p->nlocs = scm_to_unsigned_integer (x, 0, 255);
- POP (x); p->nrest = scm_to_unsigned_integer (x, 0, 1);
- POP (x); p->nargs = scm_to_unsigned_integer (x, 0, 255);
- }
+ ip += len;
- PUSH (prog);
NEXT;
}
-VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
{
SCM what;
POP (what);
@@ -189,7 +132,7 @@ VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
NEXT;
}
-VM_DEFINE_LOADER (define, "define")
+VM_DEFINE_LOADER (67, define, "define")
{
SCM sym;
size_t len;
@@ -205,6 +148,18 @@ VM_DEFINE_LOADER (define, "define")
}
/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter 59)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
+
+/*
Local Variables:
c-file-style: "gnu"
End:
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index efaa73546..06d6ca16b 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -52,43 +52,43 @@
#define RETURN(x) do { *sp = x; NEXT; } while (0)
-VM_DEFINE_FUNCTION (not, "not", 1)
+VM_DEFINE_FUNCTION (80, not, "not", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_FALSEP (x)));
}
-VM_DEFINE_FUNCTION (not_not, "not-not", 1)
+VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (!SCM_FALSEP (x)));
}
-VM_DEFINE_FUNCTION (eq, "eq?", 2)
+VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
{
ARGS2 (x, y);
RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
}
-VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
+VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
{
ARGS2 (x, y);
RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
}
-VM_DEFINE_FUNCTION (nullp, "null?", 1)
+VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_NULLP (x)));
}
-VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
+VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (!SCM_NULLP (x)));
}
-VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (SCM_EQ_P (x, y))
@@ -99,7 +99,7 @@ VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
-VM_DEFINE_FUNCTION (equal, "equal?", 2)
+VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
{
ARGS2 (x, y);
if (SCM_EQ_P (x, y))
@@ -110,13 +110,13 @@ VM_DEFINE_FUNCTION (equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
-VM_DEFINE_FUNCTION (pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_CONSP (x)));
}
-VM_DEFINE_FUNCTION (listp, "list?", 1)
+VM_DEFINE_FUNCTION (89, listp, "list?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (scm_ilength (x) >= 0));
@@ -127,7 +127,7 @@ VM_DEFINE_FUNCTION (listp, "list?", 1)
* Basic data
*/
-VM_DEFINE_FUNCTION (cons, "cons", 2)
+VM_DEFINE_FUNCTION (90, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@@ -140,21 +140,21 @@ VM_DEFINE_FUNCTION (cons, "cons", 2)
goto vm_error_not_a_pair; \
}
-VM_DEFINE_FUNCTION (car, "car", 1)
+VM_DEFINE_FUNCTION (91, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CAR (x));
}
-VM_DEFINE_FUNCTION (cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CDR (x));
}
-VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
+VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
{
ARGS2 (x, y);
VM_VALIDATE_CONS (x);
@@ -162,7 +162,7 @@ VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
RETURN (SCM_UNSPECIFIED);
}
-VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
+VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
{
ARGS2 (x, y);
VM_VALIDATE_CONS (x);
@@ -185,27 +185,27 @@ VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
RETURN (srel (x, y)); \
}
-VM_DEFINE_FUNCTION (ee, "ee?", 2)
+VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
-VM_DEFINE_FUNCTION (lt, "lt?", 2)
+VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
-VM_DEFINE_FUNCTION (le, "le?", 2)
+VM_DEFINE_FUNCTION (97, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
-VM_DEFINE_FUNCTION (gt, "gt?", 2)
+VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
-VM_DEFINE_FUNCTION (ge, "ge?", 2)
+VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@@ -229,45 +229,45 @@ VM_DEFINE_FUNCTION (ge, "ge?", 2)
RETURN (SFUNC (x, y)); \
}
-VM_DEFINE_FUNCTION (add, "add", 2)
+VM_DEFINE_FUNCTION (100, add, "add", 2)
{
FUNC2 (+, scm_sum);
}
-VM_DEFINE_FUNCTION (sub, "sub", 2)
+VM_DEFINE_FUNCTION (101, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
-VM_DEFINE_FUNCTION (mul, "mul", 2)
+VM_DEFINE_FUNCTION (102, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
-VM_DEFINE_FUNCTION (div, "div", 2)
+VM_DEFINE_FUNCTION (103, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
-VM_DEFINE_FUNCTION (quo, "quo", 2)
+VM_DEFINE_FUNCTION (104, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
-VM_DEFINE_FUNCTION (rem, "rem", 2)
+VM_DEFINE_FUNCTION (105, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
-VM_DEFINE_FUNCTION (mod, "mod", 2)
+VM_DEFINE_FUNCTION (106, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
@@ -278,7 +278,7 @@ VM_DEFINE_FUNCTION (mod, "mod", 2)
/*
* GOOPS support
*/
-VM_DEFINE_FUNCTION (slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
@@ -286,7 +286,7 @@ VM_DEFINE_FUNCTION (slot_ref, "slot-ref", 2)
RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
}
-VM_DEFINE_FUNCTION (slot_set, "slot-set", 3)
+VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
{
size_t slot;
ARGS3 (instance, idx, val);
@@ -295,6 +295,17 @@ VM_DEFINE_FUNCTION (slot_set, "slot-set", 3)
RETURN (SCM_UNSPECIFIED);
}
+/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter 79)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
/*
Local Variables:
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 6e98235de..179b6380a 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
+/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * 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 2.1 of the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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_engine.c */
@@ -46,13 +23,12 @@
* Basic operations
*/
-/* This must be the first instruction! */
-VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
{
NEXT;
}
-VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{
SCM ret;
vp->time += scm_c_get_internal_run_time () - start_time;
@@ -84,25 +60,25 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
return ret;
}
-VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
{
BREAK_HOOK ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 0, 0)
{
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
{
PUSH (SCM_UNDEFINED);
NEXT;
}
-VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
{
SCM x = *sp;
PUSH (x);
@@ -114,49 +90,49 @@ VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
* Object creation
*/
-VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
{
PUSH (SCM_UNSPECIFIED);
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
{
PUSH (SCM_BOOL_T);
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
{
PUSH (SCM_BOOL_F);
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
{
PUSH (SCM_EOL);
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
{
PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
{
PUSH (SCM_INUM0);
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
{
PUSH (SCM_I_MAKINUM (1));
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
{
int h = FETCH ();
int l = FETCH ();
@@ -164,13 +140,13 @@ VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1)
{
PUSH (SCM_MAKE_CHAR (FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -179,7 +155,7 @@ VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -190,19 +166,19 @@ VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0)
{
POP_LIST_MARK ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (cons_mark, "cons-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0)
{
POP_CONS_MARK ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
{
POP_LIST_MARK ();
SYNC_REGISTER ();
@@ -210,7 +186,7 @@ VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
{
SCM l;
POP (l);
@@ -238,7 +214,7 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
/* ref */
-VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -246,13 +222,13 @@ VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
NEXT;
}
-VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
{
unsigned int i;
SCM e = external;
@@ -266,7 +242,7 @@ VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -285,7 +261,7 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -339,14 +315,14 @@ VM_DEFINE_INSTRUCTION (toplevel_ref, "toplevel-ref", 1, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0)
{
unsigned int i;
SCM e = external;
@@ -361,14 +337,14 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -415,7 +391,7 @@ VM_DEFINE_INSTRUCTION (toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (externals, "externals", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
{
PUSH (external);
NEXT;
@@ -445,7 +421,7 @@ VM_DEFINE_INSTRUCTION (externals, "externals", 0, 0, 1)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
{
int h = FETCH ();
int l = FETCH ();
@@ -453,32 +429,32 @@ VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
{
BR (SCM_EQ_P (sp[0], sp--[1]));
}
-VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
BR (!SCM_EQ_P (sp[0], sp--[1]));
}
-VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -488,14 +464,16 @@ VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
{
SYNC_BEFORE_GC ();
- *sp = scm_c_make_closure (*sp, external);
+ *sp = scm_make_program (SCM_PROGRAM_OBJCODE (*sp),
+ SCM_PROGRAM_OBJTABLE (*sp),
+ external);
NEXT;
}
-VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -613,7 +591,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -641,7 +619,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
NULLSTACK (bp->nargs + 1);
/* Freshen the externals */
- external = bp->external;
+ external = SCM_PROGRAM_EXTERNALS (x);
for (i = 0; i < bp->nexts; i++)
CONS (external, SCM_UNDEFINED, external);
SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
@@ -712,7 +690,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
/* Postpone initializing external vars, because if the CONS causes a GC,
we want the stack marker to see the data array formatted as expected. */
data[0] = SCM_UNDEFINED;
- external = bp->external;
+ external = SCM_PROGRAM_EXTERNALS (fp[-1]);
for (i = 0; i < bp->nexts; i++)
CONS (external, SCM_UNDEFINED, external);
data[0] = external;
@@ -803,7 +781,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -812,7 +790,7 @@ VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -821,7 +799,7 @@ VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
signed short offset;
@@ -882,7 +860,7 @@ VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -901,7 +879,7 @@ VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -920,7 +898,7 @@ VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -954,7 +932,7 @@ VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -986,7 +964,7 @@ VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (48, return, "return", 0, 0, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1023,7 +1001,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
@@ -1084,7 +1062,7 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1107,7 +1085,7 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1131,6 +1109,17 @@ VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
}
/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter -1)) (goto-char (point-min))
+ (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+*/
+/*
Local Variables:
c-file-style: "gnu"
End:
diff --git a/libguile/vm.c b/libguile/vm.c
index 6f1481e23..8ca2ada6e 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -69,6 +69,8 @@
will ensure that assertions are enabled. Slows down the VM by about 30%. */
/* #define VM_ENABLE_STACK_NULLING */
+/* #define VM_ENABLE_PARANOID_ASSERTIONS */
+
#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
#define VM_ENABLE_ASSERTIONS
#endif
@@ -258,38 +260,25 @@ static SCM sym_vm_run;
static SCM sym_vm_error;
static SCM sym_debug;
-static scm_byte_t *
-vm_fetch_length (scm_byte_t *ip, size_t *lenp)
+static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
{
- /* NOTE: format defined in system/vm/conv.scm */
- *lenp = *ip++;
- if (*lenp < 254)
- return ip;
- else if (*lenp == 254)
- {
- int b1 = *ip++;
- int b2 = *ip++;
- *lenp = (b1 << 8) + b2;
- }
- else
- {
- int b1 = *ip++;
- int b2 = *ip++;
- int b3 = *ip++;
- int b4 = *ip++;
- *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
- }
- return ip;
+ scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
+ memcpy (new_bytes, bytes, len);
+ return scm_take_u8vector (new_bytes, len);
}
static SCM
-vm_make_boot_program (long len)
+vm_make_boot_program (long nargs)
{
- scm_byte_t bytes[6] = {scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
- if (SCM_UNLIKELY (len > 255 || len < 0))
+ scm_byte_t bytes[] = {0, 0, 0, 0,
+ 0, 0, 0, 0,
+ scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
+ ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness */
+ if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
abort ();
- bytes[1] = (scm_byte_t)len;
- return scm_c_make_program (bytes, 6, SCM_BOOL_F, SCM_BOOL_F);
+ bytes[9] = (scm_byte_t)nargs;
+ return scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
+ SCM_BOOL_F, SCM_EOL);
}
@@ -604,7 +593,8 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
SCM scm_load_compiled_with_vm (SCM file)
{
- SCM program = scm_objcode_to_program (scm_load_objcode (file), SCM_EOL);
+ SCM program = scm_make_program (scm_load_objcode (file),
+ SCM_BOOL_F, SCM_EOL);
return vm_run (scm_the_vm (), program, SCM_EOL);
}