diff options
35 files changed, 953 insertions, 683 deletions
@@ -76,9 +76,11 @@ define smobdatatox smobwordtox $arg0 1 end -define program +define program_objcode smobdatatox $arg0 - p *(struct scm_program*)$x + set $objcode=$x + smobdatatox $objcode + p *(struct scm_objcode*)$x end define proglocals @@ -181,7 +183,7 @@ define nextframe newline if $vmdl set $vmfp=$vmdl - set $vmbp=(struct scm_program*)(((SCM*)($vmfp[-1]))[1]) + set $vmbp=(struct scm_objcode*)((SCM*)(((SCM*)($vmfp[-1]))[1])[1]) set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4 set $vmframe=$vmframe+1 newline 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); } diff --git a/module/language/assembly.scm b/module/language/assembly.scm index baeba29a0..e66e753e2 100644 --- a/module/language/assembly.scm +++ b/module/language/assembly.scm @@ -22,28 +22,85 @@ (define-module (language assembly) #:use-module (system base pmatch) #:use-module (system vm instruction) - #:export (byte-length)) + #:export (byte-length code-pack code-unpack object->code code->object)) + +(define (len+ len) + (+ 3 len)) (define (byte-length x) (pmatch x (,label (guard (not (pair? label))) 0) - ;; instructions take one byte, hence the 1+. ((load-integer ,str) - (1+ (string-length str))) + (1+ (len+ (string-length str)))) ((load-number ,str) - (1+ (string-length str))) + (1+ (len+ (string-length str)))) ((load-string ,str) - (1+ (string-length str))) + (1+ (len+ (string-length str)))) ((load-symbol ,str) - (1+ (string-length str))) + (1+ (len+ (string-length str)))) ((load-keyword ,str) - (1+ (string-length str))) + (1+ (len+ (string-length str)))) ((define ,str) - (1+ (string-length str))) - ((assembly ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) + (1+ (len+ (string-length str)))) + ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) ;; lengths of nargs, nrest, nlocs, nexts, len, and code, respectively - (+ 1 1 1 1 4 len)) + (1+ (+ 1 1 1 1 4 len))) ((,inst . _) (guard (>= (instruction-length inst) 0)) (1+ (instruction-length inst))) (else (error "unknown instruction" x)))) + +;;; +;;; Code compress/decompression +;;; + +(define *abbreviations* + '(((make-int8 0) . (make-int8:0)) + ((make-int8 1) . (make-int8:1)))) + +(define *expansions* + (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) + +(define (code-pack code) + (or (assoc-ref code *abbreviations*) + code)) + +(define (code-unpack code) + (or (assoc-ref code *expansions*) + code)) + + +;;; +;;; Encoder/decoder +;;; + +(define (object->code x) + (cond ((eq? x #t) `(make-true)) + ((eq? x #f) `(make-false)) + ((null? x) `(make-eol)) + ((and (integer? x) (exact? x)) + (cond ((and (<= -128 x) (< x 128)) + `(make-int8 ,(modulo x 256))) + ((and (<= -32768 x) (< x 32768)) + (let ((n (if (< x 0) (+ x 65536) x))) + `(make-int16 ,(quotient n 256) ,(modulo n 256)))) + (else #f))) + ((char? x) `(make-char8 ,(char->integer x))) + (else #f))) + +(define (code->object code) + (pmatch code + ((make-true) #t) + ((make-false) #f) ;; FIXME: Same as the `else' case! + ((make-eol) '()) + ((make-int8 ,n) + (if (< n 128) n (- n 256))) + ((make-int16 ,n1 ,n2) + (let ((n (+ (* n1 256) n2))) + (if (< n 32768) n (- n 65536)))) + ((make-char8 ,n) + (integer->char n)) + ((load-string ,s) s) + ((load-symbol ,s) (string->symbol s)) + ((load-keyword ,s) (symbol->keyword (string->symbol s))) + (else #f))) diff --git a/module/language/assembly/compile-objcode.scm b/module/language/assembly/compile-objcode.scm new file mode 100644 index 000000000..1f7ad4d66 --- /dev/null +++ b/module/language/assembly/compile-objcode.scm @@ -0,0 +1,120 @@ +;;; Guile VM assembler + +;; 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. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language assembly compile-objcode) + #:use-module (system base pmatch) + #:use-module (system vm instruction) + #:use-module (system vm objcode) + #:use-module (language objcode) + #:use-module (srfi srfi-4) + #:use-module ((srfi srfi-1) #:select (fold)) + #:export (compile-objcode fill-objcode)) + +(define *program-header-len* 8) + +(define (compile-objcode assembly env . opts) + (pmatch assembly + ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code) + (letrec ((v (make-u8vector (+ *program-header-len* len))) + (i -1) + (write-byte (lambda (b) + ;; drop the load-program byte + (if (>= i 0) (u8vector-set! v i b)) + (set! i (1+ i)))) + (get-addr (lambda () i))) + (fill-objcode assembly write-byte get-addr '()) + (if (not (= i (u8vector-length v))) + (error "incorrect length in assembly" i len) + (bytecode->objcode v)))) + (else (error "bad assembly" assembly)))) + +(define (fill-objcode asm write-byte get-addr labels) + (define (write-char c) + (write-byte (char->integer c))) + (define (write-string s) + (string-for-each write-char s)) + (define (write-uint16-be x) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand x 255))) + (define (write-uint16-le x) + (write-byte (logand x 255)) + (write-byte (logand (ash x -8) 255))) + (define (write-uint32-be x) + (write-byte (logand (ash x -24) 255)) + (write-byte (logand (ash x -16) 255)) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand x 255))) + (define (write-uint32-le x) + (write-byte (logand x 255)) + (write-byte (logand (ash x -8) 255)) + (write-byte (logand (ash x -16) 255)) + (write-byte (logand (ash x -24) 255))) + (define (write-loader-len len) + (write-byte (ash len -16)) + (write-byte (logand (ash len -8) 255)) + (write-byte (logand len 255))) + (define (write-loader str) + (write-loader-len (string-length str)) + (write-string str)) + (define (write-break label) + (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) + + (let ((inst (car asm)) + (args (cdr asm))) + (let ((opcode (instruction->opcode inst)) + (len (instruction-length inst))) + (write-byte opcode) + (pmatch asm + ((load-program ,nargs ,nrest ,nlocs ,nexts + ,labels ,length . ,code) + (write-byte nargs) + (write-byte nrest) + (write-byte nlocs) + (write-byte nexts) + (write-uint32-le length) ;; FIXME! + (letrec ((i 0) + (write (lambda (x) (set! i (1+ i)) (write-byte x))) + (get-addr (lambda () i))) + (for-each (lambda (asm) + (fill-objcode asm write get-addr labels)) + code))) + ((load-integer ,str) (write-loader str)) + ((load-number ,str) (write-loader str)) + ((load-string ,str) (write-loader str)) + ((load-symbol ,str) (write-loader str)) + ((load-keyword ,str) (write-loader str)) + ((define ,str) (write-loader str)) + ((br ,l) (write-break l)) + ((br-if ,l) (write-break l)) + ((br-if-not ,l) (write-break l)) + ((br-if-eq ,l) (write-break l)) + ((br-if-not-eq ,l) (write-break l)) + ((br-if-null ,l) (write-break l)) + ((br-if-not-null ,l) (write-break l)) + ((mv-call ,n ,l) (write-byte n) (write-break l)) + (else + (cond + ((< (instruction-length inst) 0) + (error "unhanded variable-length instruction" asm)) + ((not (= (length args) len)) + (error "bad number of args to instruction" asm len)) + (else + (for-each write-byte args)))))))) diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm index 8eee64beb..fae551034 100644 --- a/module/language/assembly/spec.scm +++ b/module/language/assembly/spec.scm @@ -22,7 +22,7 @@ (define-module (language assembly spec) #:use-module (system base language) #:use-module (language objcode spec) - ;; #:use-module (language assembly compile-objcode) + #:use-module (language assembly compile-objcode) #:export (assembly)) (define (compile x e opts) @@ -34,5 +34,5 @@ #:reader read #:printer write #:parser read ;; fixme: make a verifier? - ;; #:compilers `((,objcode . ,compile)) + #:compilers `((,objcode . ,compile)) ) diff --git a/module/language/glil.scm b/module/language/glil.scm index 5254c1161..b1e42e476 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -22,10 +22,11 @@ (define-module (language glil) #:use-module (system base syntax) #:use-module (system base pmatch) + #:use-module ((srfi srfi-1) #:select (fold)) #:export (<glil-program> make-glil-program glil-program? glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts - glil-program-meta glil-program-body + glil-program-meta glil-program-body glil-program-closure-level <glil-bind> make-glil-bind glil-bind? glil-bind-vars @@ -77,7 +78,7 @@ (define-type (<glil> #:printer print-glil) ;; Meta operations - (<glil-program> nargs nrest nlocs nexts meta body) + (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f)) (<glil-bind> vars) (<glil-mv-bind> vars rest) (<glil-unbind>) @@ -97,6 +98,22 @@ (<glil-call> inst nargs) (<glil-mv-call> nargs ra)) +(define (compute-closure-level body) + (fold (lambda (x ret) + (record-case x + ((<glil-program> closure-level) (max ret closure-level)) + ((<glil-external> depth) (max ret depth)) + (else ret))) + 0 body)) + +(define %make-glil-program make-glil-program) +(define (make-glil-program . args) + (let ((prog (apply %make-glil-program args))) + (if (not (glil-program-closure-level prog)) + (set! (glil-program-closure-level prog) + (compute-closure-level (glil-program-body prog)))) + prog)) + (define (parse-glil x) (pmatch x @@ -144,7 +161,7 @@ ((<glil-module> op mod name public?) `(module ,(if public? 'public 'private) ,op ,mod ,name)) ;; controls - ((<glil-label> label) (label ,label)) + ((<glil-label> label) `(label ,label)) ((<glil-branch> inst label) `(branch ,inst ,label)) ((<glil-call> inst nargs) `(call ,inst ,nargs)) ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra))))) diff --git a/module/language/glil/Makefile.am b/module/language/glil/Makefile.am index 76c6846d4..a078cdf0c 100644 --- a/module/language/glil/Makefile.am +++ b/module/language/glil/Makefile.am @@ -1,3 +1,3 @@ -SOURCES = spec.scm compile-objcode.scm +SOURCES = spec.scm compile-objcode.scm compile-assembly.scm modpath = language/glil include $(top_srcdir)/am/guilec diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index 29c3d3fec..a2e51d507 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -26,7 +26,6 @@ #:use-module (language assembly) #:use-module (system vm instruction) #:use-module ((system vm program) #:select (make-binding)) - #:use-module (system vm conv) ;; fixme: move this module #:use-module (ice-9 receive) #:use-module ((srfi srfi-1) #:select (fold)) #:export (compile-assembly)) @@ -50,11 +49,16 @@ (if (and (null? bindings) (null? sources) (null? tail)) #f (make-subprogram - (compile-assembly - (make-glil-program 0 0 0 0 #f - (list - (make-glil-const `(,bindings ,sources ,@tail)) - (make-glil-call 'return 0))))))) + ;; we need to prepend #f for the object table. This would have + ;; even less overhead if we just appended the metadata-generating + ;; instructions after the body of the program's code. A FIXME for + ;; the future, eh. + `((make-false) + ,(compile-assembly + (make-glil-program 0 0 0 0 '() + (list + (make-glil-const `(,bindings ,sources ,@tail)) + (make-glil-call 'return 0)))))))) ;; A functional stack of names of live variables. (define (make-open-binding name ext? index) @@ -95,14 +99,14 @@ ;; A functional object table. (define *module-and-meta* 2) -(define (assoc-ref-or-acons x alist make-y) - (cond ((assoc-ref x alist) +(define (assoc-ref-or-acons alist x make-y) + (cond ((assoc-ref alist x) => (lambda (y) (values y alist))) (else (let ((y (make-y x alist))) - (values y (acons x y alist)))))) + (values y (acons x y alist)))))) (define (object-index-and-alist x alist) - (assoc-ref-or-acons x alist + (assoc-ref-or-acons alist x (lambda (x alist) (+ (length alist) *module-and-meta*)))) @@ -122,46 +126,56 @@ (values x bindings source-alist label-alist object-alist)) (record-case glil - ((<glil-program> nargs nrest nlocs nexts meta body) - (define (process-body) - (let ((nexts-stack (cons nexts nexts-stack))) - (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) - (label-alist '()) (object-alist (if (null? (cdr nexts-stack)) #f '())) (addr 0)) + ((<glil-program> nargs nrest nlocs nexts meta body closure-level) + (let ((toplevel? (null? nexts-stack))) + (define (process-body) + (let ((nexts-stack (cons nexts nexts-stack))) + (let lp ((body body) (code '()) (bindings '(())) (source-alist '()) + (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0)) + (cond + ((null? body) + (values (reverse code) + (close-all-bindings bindings addr) + (reverse source-alist) + (reverse label-alist) + (and object-alist (map car (reverse object-alist))) + addr)) + (else + (receive (subcode bindings source-alist label-alist object-alist) + (glil->assembly (car body) nargs nexts-stack bindings + source-alist label-alist object-alist addr) + (lp (cdr body) (append (reverse subcode) code) + bindings source-alist label-alist object-alist + (apply + addr (map byte-length subcode))))))))) + + (receive (code bindings sources labels objects len) + (process-body) + (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels + ,len . ,code))) (cond - ((null? body) - (values (reverse code) - (close-all-bindings bindings addr) - (reverse source-alist) - (reverse label-alist) - (and object-alist (map car (reverse object-alist))) - addr)) + (toplevel? + ;; toplevel bytecode isn't loaded by the vm, no way to do + ;; object table or closure capture (not in the bytecode, + ;; anyway) + (emit-code `(,prog))) (else - (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nargs nexts-stack bindings - source-alist label-alist object-alist addr) - (lp (cdr body) (append (reverse subcode) code) - bindings source-alist label-alist object-alist - (apply + addr (map byte-length subcode))))))))) - - ;; include len and labels - (receive (code bindings sources labels objects subaddr) - (process-body) - (let ((asm `(,@(if objects - (dump-object - (make-object-table objects - (make-meta bindings sources meta)) - addr) - '()) - (assembly ,nargs ,nrest ,nlocs ,nexts - ,labels ,subaddr - . ,code) - ,@(if closure? '((make-closure)) '())))) - (cond ((or (null? nexts-stack) (not object-alist)) - (emit-code asm)) - (else - (receive (i object-alist) - (object-index-and-alist (make-subprogram asm) object-alist) - (emit-code/object '((object-ref ,i)) object-alist))))))) + (let ((table (dump-object (make-object-table + objects + (make-meta bindings sources meta)) + addr)) + (closure (if (> closure-level 0) '((make-closure)) '()))) + (cond + (object-alist + ;; if we are being compiled from something with an object + ;; table, cache the program there + (receive (i object-alist) + (object-index-and-alist (make-subprogram `(,@table ,prog)) + object-alist) + (emit-code/object `((object-ref ,i) ,@closure) + object-alist))) + (else + ;; otherwise emit a load directly + (emit-code `(,@table ,prog ,@closure))))))))))) ((<glil-bind> vars) (values '() @@ -262,7 +276,7 @@ ((set) '(variable-set)))))) (else (receive (i object-alist) - (object-index-and-alist (make-variable-cache-cell name) + (object-index-and-alist (make-variable-cache-cell key) object-alist) (emit-code/object (case op ((ref) `((toplevel-ref ,i))) @@ -306,12 +320,12 @@ (cond ((object->code x) => list) ((variable-cache-cell? x) (dump (variable-cache-cell-key x))) - ((subprogram? x) (list (subprogram-code x))) + ((subprogram? x) (subprogram-code x)) ((and (integer? x) (exact? x)) (let ((str (do ((n x (quotient n 256)) (l '() (cons (modulo n 256) l))) ((= n 0) - (apply u8vector l))))) + (list->string (map integer->char l)))))) `((load-integer ,str)))) ((number? x) `((load-number ,(number->string x)))) @@ -322,23 +336,25 @@ ((keyword? x) `((load-keyword ,(symbol->string (keyword->symbol x))))) ((list? x) - (fold (lambda (x y) - (append (dump x) y)) + (fold append (let ((len (length x))) (if (>= len 65536) (too-long "list")) `((list ,(quotient len 256) ,(modulo len 256)))) - x)) + (fold (lambda (x y) (cons (dump x) y)) + '() + x))) ((pair? x) `(,@(dump (car x)) ,@(dump (cdr x)) (cons))) ((vector? x) - (fold (lambda (x y) - (append (dump x) y)) + (fold append (let ((len (vector-length x))) (if (>= len 65536) (too-long "vector")) `((vector ,(quotient len 256) ,(modulo len 256)))) - (vector->list x))) + (fold (lambda (x y) (cons (dump x) y)) + '() + (vector->list x)))) (else (error "assemble: unrecognized object" x))))) diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm index c288c8f9b..deb76ee81 100644 --- a/module/language/glil/spec.scm +++ b/module/language/glil/spec.scm @@ -43,6 +43,6 @@ #:reader read #:printer write-glil #:parser parse-glil - #:compilers `((,objcode . ,compile) - (,assembly . ,compile-asm)) + #:compilers `((,assembly . ,compile-asm) + (,objcode . ,compile)) ) diff --git a/module/language/objcode.scm b/module/language/objcode.scm new file mode 100644 index 000000000..aea546c66 --- /dev/null +++ b/module/language/objcode.scm @@ -0,0 +1,52 @@ +;;; Guile Virtual Machine Object Code + +;; 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. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language objcode) + #:export (encode-length decode-length)) + + +;;; +;;; Variable-length interface +;;; + +;; NOTE: decoded in vm_fetch_length in vm.c as well. + +(define (encode-length len) + (cond ((< len 254) (u8vector len)) + ((< len (* 256 256)) + (u8vector 254 (quotient len 256) (modulo len 256))) + ((< len most-positive-fixnum) + (u8vector 255 + (quotient len (* 256 256 256)) + (modulo (quotient len (* 256 256)) 256) + (modulo (quotient len 256) 256) + (modulo len 256))) + (else (error "Too long code length:" len)))) + +(define (decode-length pop) + (let ((x (pop))) + (cond ((< x 254) x) + ((= x 254) (+ (ash x 8) (pop))) + (else + (let* ((b2 (pop)) + (b3 (pop)) + (b4 (pop))) + (+ (ash x 24) (ash b2 16) (ash b3 8) b4)))))) diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm index 5e0ae3cc3..89d2793d4 100644 --- a/module/language/objcode/spec.scm +++ b/module/language/objcode/spec.scm @@ -23,6 +23,7 @@ #:use-module (system base language) #:use-module (language value spec) #:use-module (system vm objcode) + #:use-module (system vm program) #:export (objcode make-objcode-env)) (define (make-objcode-env module externals) @@ -35,7 +36,7 @@ (if env (cdr env) '())) (define (objcode->value x e opts) - (let ((thunk (objcode->program x (objcode-env-externals e)))) + (let ((thunk (make-program x #f (objcode-env-externals e)))) (if e (save-module-excursion (lambda () @@ -47,6 +48,6 @@ #:title "Guile Object Code" #:version "0.3" #:reader #f - #:printer (lambda (x port) (uniform-vector-write (objcode->u8vector x) port)) + #:printer write-objcode #:compilers `((,value . ,objcode->value)) ) diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm index 47fb6724f..462fe7f2f 100644 --- a/module/language/scheme/inline.scm +++ b/module/language/scheme/inline.scm @@ -201,3 +201,6 @@ (x) x (x y) (cons x y) (x y . rest) (cons x (cons* y . rest))) + +(define-inline acons + (x y z) (cons (cons x y) z)) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 513680aaa..873d7ab7c 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -133,7 +133,7 @@ (define (make-byte-decoder bytes) - (let ((addr 0) (size (u8vector-length bytes))) + (let ((addr 8) (size (u8vector-length bytes))) (define (pop) (let ((byte (u8vector-ref bytes addr))) (set! addr (1+ addr)) @@ -141,54 +141,46 @@ (define (sublist lst start end) (take (drop lst start) (- end start))) (lambda () - (if (< addr size) - (let* ((start addr) - (inst (opcode->instruction (pop))) - (n (instruction-length inst)) - (code (if (< n 0) - ;; variable length - (let* ((end (+ (decode-length pop) addr)) - (subbytes (sublist - (u8vector->list bytes) - addr end)) - (->string? (not (eq? inst 'load-program)))) - (set! addr end) - (list inst - (if ->string? - (list->string - (map integer->char subbytes)) - (apply u8vector subbytes)))) - ;; fixed length - (do ((n n (1- n)) - (l '() (cons (pop) l))) - ((= n 0) (cons* inst (reverse! l))))))) - (values start addr code)) - (values #f #f #f))))) + (cond + ((>= addr size) + (values #f #f #f)) + (else + (let* ((start addr) + (inst (opcode->instruction (pop)))) + (cond + ((eq? inst 'load-program) + ;; FIXME just turn it into a bytecode slice? + (pk 'yo addr size) + (let* ((len (+ 8 + (u8vector-ref bytes (+ addr 4)) + (ash (u8vector-ref bytes (+ addr 5)) 8) + (ash (u8vector-ref bytes (+ addr 6)) 16) + (ash (u8vector-ref bytes (+ addr 7)) 24))) + (end (+ len addr)) + (subbytes (sublist (u8vector->list bytes) addr end))) + (set! addr end) + (values start addr + (list inst (list->u8vector subbytes))))) + ((< (instruction-length inst) 0) + (let* ((end (+ (decode-length pop) addr)) + (subbytes (sublist + (u8vector->list bytes) + addr end))) + (set! addr end) + (values start addr + (list inst + (list->string (map integer->char subbytes)))))) + (else + ;; fixed length + (do ((n (instruction-length inst) (1- n)) + (l '() (cons (pop) l))) + ((= n 0) (values start addr (cons* inst (reverse! l))))))))))))) ;;; ;;; Variable-length interface ;;; -;; NOTE: decoded in vm_fetch_length in vm.c as well. - -(define (encode-length len) - (cond ((< len 254) (u8vector len)) - ((< len (* 256 256)) - (u8vector 254 (quotient len 256) (modulo len 256))) - ((< len most-positive-fixnum) - (u8vector 255 - (quotient len (* 256 256 256)) - (modulo (quotient len (* 256 256)) 256) - (modulo (quotient len 256) 256) - (modulo len 256))) - (else (error "Too long code length:" len)))) - (define (decode-length pop) - (let ((len (pop))) - (cond ((< len 254) len) - ((= len 254) (+ (* (pop) 256) (pop))) - (else (+ (* (pop) 256 256 256) - (* (pop) 256 256) - (* (pop) 256) - (pop)))))) + (let* ((a (pop)) (b (pop)) (c (pop))) + (+ (ash a 16) (ash b 8) c))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 8bd565ba4..5d7ebde88 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -29,12 +29,13 @@ #:use-module (ice-9 receive) #:export (disassemble-objcode disassemble-program disassemble-bytecode)) +;; FIXME: the header, and arity (define (disassemble-objcode objcode . opts) - (let* ((prog (objcode->program objcode)) + (let* ((prog (make-program objcode)) ;; fixme: no need to make a program... (arity (program-arity prog)) (nlocs (arity:nlocs arity)) (nexts (arity:nexts arity)) - (bytes (program-bytecode prog))) + (bytes (objcode->u8vector (program-objcode prog)))) (format #t "Disassembly of ~A:\n\n" objcode) (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) (disassemble-bytecode bytes #f 0 #f #f '()))) @@ -45,7 +46,8 @@ (nrest (arity:nrest arity)) (nlocs (arity:nlocs arity)) (nexts (arity:nexts arity)) - (bytes (program-bytecode prog)) + ;; FIXME: header and arity, etc + (bytes (objcode->u8vector (program-objcode prog))) (objs (program-objects prog)) (meta (program-meta prog)) (exts (program-external prog)) @@ -66,12 +68,14 @@ (if meta (disassemble-meta prog (meta))) ;; Disassemble other bytecode in it - (for-each - (lambda (x) - (if (program? x) - (begin (display "----------------------------------------\n") - (apply disassemble-program x opts)))) - (vector->list objs)))) + ;; FIXME: something about the module. + (if objs + (for-each + (lambda (x) + (if (program? x) + (begin (display "----------------------------------------\n") + (apply disassemble-program x opts)))) + (cddr (vector->list objs)))))) (define (disassemble-bytecode bytes objs nargs blocs bexts sources) (let ((decode (make-byte-decoder bytes)) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 85a223e98..6c8adf80c 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -52,8 +52,9 @@ (define vm-frame-number (make-object-property)) (define vm-frame-address (make-object-property)) +;; FIXME: the header. (define (bootstrap-frame? frame) - (let ((code (program-bytecode (frame-program frame)))) + (let ((code (objcode->u8vector (program-objcode (frame-program frame))))) (and (= (uniform-vector-length code) 6) (= (uniform-vector-ref code 5) (instruction->opcode 'halt))))) diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm index 70fd18adf..cf21220ee 100644 --- a/module/system/vm/objcode.scm +++ b/module/system/vm/objcode.scm @@ -20,7 +20,8 @@ ;;; Code: (define-module (system vm objcode) - #:export (objcode->u8vector objcode? objcode->program bytecode->objcode - load-objcode)) + #:export (objcode->u8vector objcode? bytecode->objcode + load-objcode write-objcode + word-size byte-order)) (dynamic-call "scm_init_objcodes" (dynamic-link "libguile")) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index b2ad299b6..5bf243785 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -20,19 +20,21 @@ ;;; Code: (define-module (system vm program) - #:export (arity:nargs arity:nrest arity:nlocs arity:nexts + #:export (make-program + + arity:nargs arity:nrest arity:nlocs arity:nexts make-binding binding:name binding:extp binding:index binding:start binding:end - source:addr source:line source:column source:file - program-bindings program-sources - program-properties program-property program-documentation - program-name + source:addr source:line source:column source:file + program-bindings program-sources + program-properties program-property program-documentation + program-name - program-arity program-external-set! program-meta - program-bytecode program? program-objects - program-module program-base program-external)) + program-arity program-external-set! program-meta + program-objcode program? program-objects + program-module program-base program-external)) (dynamic-call "scm_init_programs" (dynamic-link "libguile")) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index a46b85213..de5c3fa21 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -21,7 +21,7 @@ (define-module (system vm vm) #:use-module (system vm frame) - #:use-module (system vm objcode) + #:use-module (system vm program) #:export (vm? the-vm make-vm vm-version vm:ip vm:sp vm:fp vm:last-ip @@ -38,4 +38,4 @@ (define (vms:clock stat) (vector-ref stat 1)) (define (vm-load vm objcode) - (vm (objcode->program objcode))) + (vm (make-program objcode))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index c2266e44d..a8bd6233c 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -24,6 +24,7 @@ SUBDIRS = standalone SCM_TESTS = tests/alist.test \ tests/and-let-star.test \ tests/arbiters.test \ + tests/asm-to-bytecode.test \ tests/bit-operations.test \ tests/c-api.test \ tests/chars.test \ diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test new file mode 100644 index 000000000..7be935dd9 --- /dev/null +++ b/test-suite/tests/asm-to-bytecode.test @@ -0,0 +1,83 @@ +;;;; test assembly to bytecode compilation -*- scheme -*- +;;;; +;;;; 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 library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite tests asm-to-bytecode) + #:use-module (test-suite lib) + #:use-module (system vm instruction) + #:use-module (language assembly compile-objcode)) + +(define (munge-bytecode v) + (let ((newv (make-u8vector (vector-length v)))) + (let lp ((i 0)) + (if (= i (vector-length v)) + newv + (let ((x (vector-ref v i))) + (u8vector-set! newv i (if (symbol? x) + (instruction->opcode x) + x)) + (lp (1+ i))))))) + +(define (comp-test x y) + (let* ((y (munge-bytecode y)) + (len (u8vector-length y)) + (v (make-u8vector len)) + (i 0)) + (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i))) + (define (get-addr) i) + (run-test `(length ,x) #t + (lambda () + (fill-objcode x write-byte get-addr '()) + (= i len))) + (run-test `(compile-equal? ,x ,y) #t + (lambda () + (equal? v y))))) + +(with-test-prefix "compiler" + (with-test-prefix "asm-to-bytecode" + + (comp-test '(make-int8 3) + #(make-int8 3)) + + (comp-test `(load-integer ,(string (integer->char 0))) + #(load-integer 0 0 1 0)) + + (comp-test `(load-integer ,(string (integer->char 255))) + #(load-integer 0 0 1 255)) + + (comp-test `(load-integer ,(string (integer->char 1) (integer->char 0))) + #(load-integer 0 0 2 1 0)) + + (comp-test '(load-number "3.14") + (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.) + (char->integer #\1) (char->integer #\4))) + + (comp-test '(load-string "foo") + (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) + (char->integer #\o))) + + (comp-test '(load-symbol "foo") + (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) + (char->integer #\o))) + + (comp-test '(load-keyword "qux") + (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u) + (char->integer #\x))) + + ;; fixme: little-endian test. + (comp-test '(load-program 3 2 1 0 '() 3 (make-int8 3) (return)) + (vector 'load-program 3 2 1 0 3 0 0 0 + (instruction->opcode 'make-int8) 3 + (instruction->opcode 'return))))) |