mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
static opcodes; refactor program/objcode division; use new assembly pipeline
* gdbinit: Untested attempts to get the stack fondling macros to deal with the new program representation. * libguile/frames.c (scm_vm_frame_arguments, scm_vm_frame_source) (scm_vm_frame_local_ref, scm_vm_frame_local_set_x): SCM_PROGRAM_DATA is a struct scm_objcode*. * libguile/instructions.h: * libguile/instructions.c: Hide the instruction table and the struct scm_instruction structure; all access to instructions now goes through procedures. This is because instructions are no longer in a packed array indexed by opcode. Also, declare a mask that all instructions should fit in. * libguile/objcodes.h: * libguile/objcodes.c: Rewrite so that object code directly maps its arity and length from its bytecode. This makes it unnecessary to keep this information in programs, allowing programs to be simple conses between the code (objcodes) and data (the object table and the closure variables). * libguile/programs.c (scm_make_program): Rework so that make-program takes objcode, an object table, and externals as arguments. It's much clearer this way, and we avoid malloc(). * libguile/stacks.c (is_vm_bootstrap_frame): Update for program/objcode changes. * libguile/vm-engine.c (vm_run): Initialize the jump table on the first run, with the opcodes declared in the instruction sources, and with bad instructions raising an error instead of wandering off into the Unknown. * libguile/vm-engine.h (FETCH_LENGTH): Always represent lengths as 3 bytes. The old code was too error-prone. (NEXT_JUMP): Mask the instruction with SCM_VM_INSTRUCTION_MASK. (NEW_FRAME): Update for program/objcode changes. * libguile/vm-expand.h (VM_DEFINE_FUNCTION, VM_DEFINE_INSTRUCTION) (VM_DEFINE_LOADER): Update so that we explicitly specify opcodes, so that we have a stable bytecode API. * libguile/vm-i-loader.c: Update license to LGPLv2+. Explicitly declare opcodes. (load-integer): Use an int instead of a long as the accumulator; still need to revisit this code at some point, I think. (load-program): Simplify, thankfully!! Just creates the objcode slice and rolls with it. * libguile/vm-i-scheme.c: Number the opcodes explicitly. * libguile/vm-i-system.c: Update license to LGPLv2+. Explicitly declare opcodes. (make-closure): Update for new program API. * libguile/vm.c (vm_make_boot_program): Update for new program/objcode API. Still a bit ugly. (scm_load_compiled_with_vm): Update for new program/objcode API. * module/language/assembly.scm (byte-length): Fix byte-length calculation for loaders, and load-program. (code-pack, code-unpack): Start to move things from (system vm conv) here. (object->code, code->object): More things from conv.scm. * module/language/glil.scm (<glil-program>): Add a new field, closure-level. (make-glil-program, compute-closure-level): Calculate the "closure level" when making a glil program. This is the maximum depth of external binding refs in this closure. (unparse-glil): Fix label serialization. * module/language/glil/compile-assembly.scm (make-meta): Prepend #f for the meta's object table, though maybe in the future we can avoid creating assembly in the first place. (assoc-ref-or-acons, object-index-and-alist): GRRR! Caught again by the different sets of arguments to assoc and assoc-ref! (glil->assembly): Attempt to make the <glil-program> case more readable, and fix the bugs. Sorry I don't know how to comment this change any more than this. (glil->assembly): For <glil-module> serialize the whole key, not just the name. (dump-object): subprogram-code is already a list. Serialize integers as strings, not u8vectors. Fix the order of lists and vectors. * module/language/glil/spec.scm (glil): Switch orders, so we prefer glil -> assembly -> objcode. Actually glil->objcode doesn't work any more, needs to be removed I think. * module/language/objcode/spec.scm (objcode->value): s/objcode->program/make-program/. * module/language/scheme/inline.scm: Add acons inline. * module/system/vm/conv.scm (make-byte-decoder): Skip the first 8 bytes, they are header. Handle subprograms properly. Still needs help though. (decode-length): Lengths are always 3 bytes now. * module/system/vm/disasm.scm: Superficial changes to keep things working. I'd like to fix this better in the future. * module/system/vm/frame.scm (bootstrap-frame?): Fixes for program-bytecode. * module/system/vm/program.scm: Export make-program. It's program-objcode now, no more program-bytecode. * module/system/vm/vm.scm (vm-load): Use make-program. * test-suite/tests/asm-to-bytecode.test: New test, very minimal. * module/system/vm/objcode.scm: Export word-size, byte-order, and write-objcode.
This commit is contained in:
Andy Wingo
parent
f1d7723bb3
commit
53e28ed9b2
35 changed files with 952 additions and 682 deletions
8
gdbinit
8
gdbinit
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
scm_op_last = SCM_VM_NUM_INSTRUCTIONS
|
||||
};
|
||||
|
||||
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 */
|
||||
};
|
||||
|
||||
#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);
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
||||
|
|
@ -64,19 +65,6 @@
|
|||
|
||||
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"
|
||||
|
|
@ -84,13 +72,14 @@ make_objcode_by_mmap (int fd)
|
|||
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);
|
||||
struct scm_objcode *data, *parent_data;
|
||||
SCM ret;
|
||||
|
||||
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_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)));
|
||||
|
||||
scm_gc_free (p, size, "objcode");
|
||||
data = (struct scm_objcode*)ptr;
|
||||
if (data->base + data->len > parent_data->base + parent_data->len)
|
||||
abort ();
|
||||
|
||||
return 0;
|
||||
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);
|
||||
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));
|
||||
|
||||
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;
|
||||
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));
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@
|
|||
#include "libguile/validate.h"
|
||||
#include "libguile/procs.h"
|
||||
#include "libguile/procprop.h"
|
||||
#include "libguile/objcodes.h"
|
||||
#include "libguile/programs.h"
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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; \
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* 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 General Public License for more details.
|
||||
*
|
||||
* 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
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* 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 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.
|
||||
*
|
||||
* 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);
|
||||
|
||||
/* init meta data */
|
||||
if (SCM_PROGRAM_P (x))
|
||||
{
|
||||
meta = x;
|
||||
POP (x);
|
||||
}
|
||||
|
||||
/* 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);
|
||||
}
|
||||
|
||||
FETCH_LENGTH (len);
|
||||
POP (objs);
|
||||
SYNC_REGISTER ();
|
||||
prog = scm_c_make_program (ip, len, objs, program);
|
||||
p = SCM_PROGRAM_DATA (prog);
|
||||
|
||||
if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
|
||||
scm_c_vector_set_x (objs, 0, scm_current_module ());
|
||||
|
||||
objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
|
||||
len = sizeof (struct scm_objcode) + SCM_OBJCODE_LEN (objcode);
|
||||
|
||||
PUSH (scm_make_program (objcode, objs, SCM_EOL));
|
||||
|
||||
ip += len;
|
||||
|
||||
/* 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);
|
||||
}
|
||||
|
||||
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;
|
||||
|
|
@ -204,6 +147,18 @@ VM_DEFINE_LOADER (define, "define")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
/*
|
||||
(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"
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* 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 General Public License for more details.
|
||||
*
|
||||
* 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
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
* Lesser General Public License for more details.
|
||||
*
|
||||
* 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 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.
|
||||
*
|
||||
* 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;
|
||||
|
|
@ -1130,6 +1108,17 @@ VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
/*
|
||||
(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"
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
120
module/language/assembly/compile-objcode.scm
Normal file
120
module/language/assembly/compile-objcode.scm
Normal file
|
|
@ -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))))))))
|
||||
|
|
@ -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))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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)))))))))
|
||||
((<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)))))))))
|
||||
|
||||
;; 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)))))))
|
||||
(receive (code bindings sources labels objects len)
|
||||
(process-body)
|
||||
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
|
||||
,len . ,code)))
|
||||
(cond
|
||||
(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
|
||||
(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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -43,6 +43,6 @@
|
|||
#:reader read
|
||||
#:printer write-glil
|
||||
#:parser parse-glil
|
||||
#:compilers `((,objcode . ,compile)
|
||||
(,assembly . ,compile-asm))
|
||||
#:compilers `((,assembly . ,compile-asm)
|
||||
(,objcode . ,compile))
|
||||
)
|
||||
|
|
|
|||
52
module/language/objcode.scm
Normal file
52
module/language/objcode.scm
Normal file
|
|
@ -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))))))
|
||||
|
|
@ -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))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
83
test-suite/tests/asm-to-bytecode.test
Normal file
83
test-suite/tests/asm-to-bytecode.test
Normal file
|
|
@ -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)))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue