diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/frames.c | 11 | ||||
-rw-r--r-- | libguile/instructions.c | 63 | ||||
-rw-r--r-- | libguile/instructions.h | 30 | ||||
-rw-r--r-- | libguile/objcodes.c | 165 | ||||
-rw-r--r-- | libguile/objcodes.h | 30 | ||||
-rw-r--r-- | libguile/procs.c | 1 | ||||
-rw-r--r-- | libguile/programs.c | 151 | ||||
-rw-r--r-- | libguile/programs.h | 25 | ||||
-rw-r--r-- | libguile/stacks.c | 4 | ||||
-rw-r--r-- | libguile/vm-engine.c | 43 | ||||
-rw-r--r-- | libguile/vm-engine.h | 14 | ||||
-rw-r--r-- | libguile/vm-expand.h | 28 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 137 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 69 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 175 | ||||
-rw-r--r-- | libguile/vm.c | 44 |
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); } |