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

Remove stack programs, objcode, and the old VM.

Browse source 
* libguile/Makefile.am:
* libguile/vm-i-loader.c:
* libguile/vm-i-scheme.c:
* libguile/vm-i-system.c: Remove the old VM files, and the rules to
  build the .i files.

* libguile/vm-engine.c:
* libguile/vm.c: Remove the old VM.  Woot!

* libguile/_scm.h (SCM_OBJCODE_COOKIE, SCM_OBJCODE_ENDIANNESS_OFFSET)
  (SCM_OBJCODE_WORD_SIZE_OFFSET): Remove.

* libguile/evalext.c (scm_self_evaluating_p): Remove objcode and program
  cases.

* libguile/frames.c (scm_frame_num_locals, scm_frame_previous): Remove
  program cases.

* libguile/gc.c (scm_i_tag_name): Remove objcode case.
* libguile/goops.c (scm_class_of, create_standard_classes): Remove
  objcode and program cases.

* libguile/instructions.h:
* libguile/instructions.c (scm_instruction_list, scm_instruction_p)
  (scm_instruction_length, scm_instruction_pops, scm_instruction_pushes)
  (scm_instruction_to_opcode, scm_opcode_to_instruction): Remove old VM
  code.

* libguile/objcodes.h:
* libguile/objcodes.c: Remove the objcode data type, and handling for
  objcode files.

* libguile/print.c: Remove objcode and program printers.

* libguile/procprop.c: Remove program cases.
* libguile/procs.c:

* libguile/programs.h:
* libguile/programs.c: Remove old program code.

* libguile/smob.c: Remove objcodes include.

* libguile/snarf.h: Remove static program defines.

* libguile/stacks.c: Remove program case.

* libguile/tags.h: Remove program and objcode tc7s.

* module/ice-9/session.scm (procedure-arguments)
* module/language/tree-il/analyze.scm (validate-arity)
* module/statprof.scm (get-call-data, procedure=?)
* module/system/vm/frame.scm (frame-bindings)
  (frame-call-representation): Remove old program cases.

* module/system/repl/debug.scm (frame->module): Add a FIXME.

* module/system/vm/instruction.scm: Remove old exports.

* module/system/vm/program.scm: Remove old program code.
This commit is contained in:
Andy Wingo 2013-11-08 18:28:24 +01:00
parent 84680d2382
commit 1c33be992e
31 changed files with 51 additions and 4308 deletions
Download patch file Download diff file Expand all files Collapse all files

10
libguile/Makefile.am
View file

@ -428,11 +428,6 @@ DOT_DOC_FILES = \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
.c.i:
$(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@
vm-operations.h: vm-engine.c
@echo '/* This file was generated automatically from $<; do not' > $@
@echo ' edit. See the source file for copyright information. */' >> $@
@ -476,7 +471,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
private-gc.h private-options.h ports-internal.h
# vm instructions
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
noinst_HEADERS += vm-engine.c
libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES = @LIBLOBJS@
@ -802,7 +797,6 @@ chknew-E chknew-SIG: \
MOSTLYCLEANFILES = \
scmconfig.h scmconfig.h.tmp
CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi \
vm-i-*.i
CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi
MAINTAINERCLEANFILES = c-tokenize.c

7
libguile/_scm.h
View file

@ -280,13 +280,6 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
#define SCM_OBJCODE_MACHINE_VERSION_STRING \
SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE "-" SCM_OBJCODE_VERSION_STRING
/* The objcode magic header. */
#define SCM_OBJCODE_COOKIE \
"GOOF----" SCM_OBJCODE_MACHINE_VERSION_STRING
#define SCM_OBJCODE_ENDIANNESS_OFFSET 8
#define SCM_OBJCODE_WORD_SIZE_OFFSET 11
#endif /* SCM__SCM_H */
/*

4
libguile/evalext.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -81,14 +81,12 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
case scm_tc7_objcode:
case scm_tc7_vm:
case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_rtl_program:
case scm_tc7_program:
case scm_tc7_bytevector:
case scm_tc7_array:
case scm_tc7_bitvector:

22
libguile/frames.c
View file

@ -120,35 +120,18 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_num_locals
{
SCM *fp, *sp, *p;
SCM *sp, *p;
unsigned int n = 0;
SCM_VALIDATE_VM_FRAME (1, frame);
fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
if (SCM_RTL_PROGRAM_P (fp[-1]))
/* The frame size of an RTL program is fixed, except in the case of
passing a wrong number of arguments to the program. So we do
need to use an SP for determining the number of locals. */
return scm_from_ptrdiff_t (sp + 1 - p);
sp = SCM_VM_FRAME_SP (frame);
p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
while (p <= sp)
{
if (SCM_UNPACK (p[0]) == 0)
/* skip over not-yet-active frame */
p += 3;
else
{
p++;
n++;
}
}
return scm_from_uint (n);
}
#undef FUNC_NAME
@ -311,8 +294,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
SCM_VM_FRAME_OFFSET (frame));
proc = scm_frame_procedure (frame);
if ((SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc))
&& SCM_PROGRAM_IS_BOOT (proc))
if (SCM_RTL_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
goto again;
else
return frame;

2
libguile/gc.c
View file

@ -944,8 +944,6 @@ scm_i_tag_name (scm_t_bits tag)
return "dynamic state";
case scm_tc7_frame:
return "frame";
case scm_tc7_objcode:
return "objcode";
case scm_tc7_vm:
return "vm";
case scm_tc7_vm_cont:

11
libguile/goops.c
View file

@ -155,7 +155,6 @@ static SCM class_hashtable;
static SCM class_fluid;
static SCM class_dynamic_state;
static SCM class_frame;
static SCM class_objcode;
static SCM class_vm;
static SCM class_vm_cont;
static SCM class_bytevector;
@ -266,8 +265,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_dynamic_state;
case scm_tc7_frame:
return class_frame;
case scm_tc7_objcode:
return class_objcode;
case scm_tc7_vm:
return class_vm;
case scm_tc7_vm_cont:
@ -294,13 +291,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
case scm_tc7_program:
case scm_tc7_rtl_program:
/* Although SCM_SUBR_GENERIC is specific to stack programs
currently, in practice only stack programs pass
SCM_PROGRAM_IS_PRIMITIVE_GENERIC. In the future this will
change to be the other way around, when subrs become RTL
programs. */
if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)
&& SCM_UNPACK (*SCM_SUBR_GENERIC (x)))
return scm_class_primitive_generic;
@ -2521,8 +2512,6 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_frame, "<frame>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_objcode, "<objcode>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_vm, "<vm>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_vm_cont, "<vm-continuation>",

162
libguile/instructions.c
View file

@ -27,20 +27,6 @@
#include "instructions.h"
struct scm_instruction {
enum scm_opcode opcode; /* opcode */
const char *name; /* instruction name */
signed char len; /* Instruction length. This may be -1 for
the loader (see the `VM_LOADER'
macro). */
signed char npop; /* The number of values popped. This may be
-1 for insns like `call' which can take
any number of arguments. */
char npush; /* the number of values pushed */
SCM symname; /* filled in later */
};
SCM_SYMBOL (sym_left_arrow, "<-");
SCM_SYMBOL (sym_bang, "!");
@ -133,38 +119,6 @@ struct scm_rtl_instruction {
static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static const struct scm_instruction*
fetch_instruction_table ()
{
static struct scm_instruction *table = NULL;
scm_i_pthread_mutex_lock (&itable_lock);
if (SCM_UNLIKELY (!table))
{
size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
int i;
table = malloc (bytes);
memset (table, 0, bytes);
#define VM_INSTRUCTION_TO_TABLE 1
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_TABLE
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
{
table[i].opcode = i;
if (table[i].name)
table[i].symname = scm_from_utf8_symbol (table[i].name);
else
table[i].symname = SCM_BOOL_F;
}
}
scm_i_pthread_mutex_unlock (&itable_lock);
return table;
}
static const struct scm_rtl_instruction*
fetch_rtl_instruction_table ()
{
@ -196,51 +150,9 @@ fetch_rtl_instruction_table ()
return table;
}
static const struct scm_instruction *
scm_lookup_instruction_by_name (SCM name)
{
static SCM instructions_by_name = SCM_BOOL_F;
const struct scm_instruction *table = fetch_instruction_table ();
SCM op;
if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
{
unsigned int i;
instructions_by_name =
scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (scm_is_true (table[i].symname))
scm_hashq_set_x (instructions_by_name, table[i].symname,
SCM_I_MAKINUM (i));
}
op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
if (SCM_I_INUMP (op))
return &table[SCM_I_INUM (op)];
return NULL;
}
/* Scheme interface */
SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
(void),
"")
#define FUNC_NAME s_scm_instruction_list
{
SCM list = SCM_EOL;
int i;
const struct scm_instruction *ip = fetch_instruction_table ();
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (ip[i].name)
list = scm_cons (ip[i].symname, list);
return scm_reverse_x (list, SCM_EOL);
}
#undef FUNC_NAME
SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
(void),
"")
@ -297,80 +209,6 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_instruction_p
{
return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
}
#undef FUNC_NAME
SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
(SCM inst),
"")
#define FUNC_NAME s_scm_instruction_length
{
const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->len);
}
#undef FUNC_NAME
SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
(SCM inst),
"")
#define FUNC_NAME s_scm_instruction_pops
{
const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->npop);
}
#undef FUNC_NAME
SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
(SCM inst),
"")
#define FUNC_NAME s_scm_instruction_pushes
{
const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->npush);
}
#undef FUNC_NAME
SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
(SCM inst),
"")
#define FUNC_NAME s_scm_instruction_to_opcode
{
const struct scm_instruction *ip;
SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
return SCM_I_MAKINUM (ip->opcode);
}
#undef FUNC_NAME
SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
(SCM op),
"")
#define FUNC_NAME s_scm_opcode_to_instruction
{
scm_t_signed_bits opcode;
SCM ret = SCM_BOOL_F;
SCM_MAKE_VALIDATE (1, op, I_INUMP);
opcode = SCM_I_INUM (op);
if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
ret = fetch_instruction_table ()[opcode].symname;
if (scm_is_false (ret))
scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
return ret;
}
#undef FUNC_NAME
void
scm_bootstrap_instructions (void)
{

17
libguile/instructions.h
View file

@ -78,25 +78,8 @@ enum scm_rtl_opcode
#define SCM_VM_NUM_INSTRUCTIONS (1<<8)
#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
enum scm_opcode {
#define VM_INSTRUCTION_TO_OPCODE 1
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_OPCODE
};
SCM_INTERNAL SCM scm_rtl_instruction_list (void);
SCM_API SCM scm_instruction_list (void);
SCM_API SCM scm_instruction_p (SCM obj);
SCM_API SCM scm_instruction_length (SCM inst);
SCM_API SCM scm_instruction_pops (SCM inst);
SCM_API SCM scm_instruction_pushes (SCM inst);
SCM_API SCM scm_instruction_to_opcode (SCM inst);
SCM_API SCM scm_opcode_to_instruction (SCM op);
SCM_INTERNAL void scm_bootstrap_instructions (void);
SCM_INTERNAL void scm_init_instructions (void);

206
libguile/objcodes.c
View file

@ -42,18 +42,6 @@
#include "programs.h"
#include "objcodes.h"
/* Before, we used __BYTE_ORDER, but that is not defined on all
systems. So punt and use automake, PDP endianness be damned. */
#define SCM_BYTE_ORDER_BE 4321
#define SCM_BYTE_ORDER_LE 1234
/* Byte order of the build machine. */
#ifdef WORDS_BIGENDIAN
#define SCM_BYTE_ORDER SCM_BYTE_ORDER_BE
#else
#define SCM_BYTE_ORDER SCM_BYTE_ORDER_LE
#endif
/* This file contains the loader for Guile's on-disk format: ELF with
some custom tags in the dynamic segment. */
@ -94,7 +82,6 @@ static void register_elf (char *data, size_t len);
enum bytecode_kind
{
BYTECODE_KIND_NONE,
BYTECODE_KIND_GUILE_2_0,
BYTECODE_KIND_GUILE_2_2
};
@ -103,14 +90,6 @@ pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr)
{
switch (bytecode_kind)
{
case BYTECODE_KIND_GUILE_2_0:
{
SCM objcode;
scm_t_bits tag = SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0);
objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0);
return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED);
}
case BYTECODE_KIND_GUILE_2_2:
{
return scm_i_make_rtl_program ((scm_t_uint32 *) ptr);
@ -309,11 +288,6 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff;
switch (major)
{
case 0x0200:
bytecode_kind = BYTECODE_KIND_GUILE_2_0;
if (minor > SCM_OBJCODE_MINOR_VERSION)
return "incompatible bytecode version";
break;
case 0x0202:
bytecode_kind = BYTECODE_KIND_GUILE_2_2;
if (minor)
@ -332,12 +306,6 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
switch (bytecode_kind)
{
case BYTECODE_KIND_GUILE_2_0:
if (init)
return "unexpected DT_INIT";
if ((scm_t_uintptr) entry % 8)
return "unaligned DT_GUILE_ENTRY";
break;
case BYTECODE_KIND_GUILE_2_2:
if ((scm_t_uintptr) init % 4)
return "unaligned DT_INIT";
@ -590,55 +558,6 @@ SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0,
#undef FUNC_NAME
/*
* Objcode type
*/
/* Convert X, which is in byte order BYTE_ORDER, to its native
representation. */
static inline uint32_t
to_native_order (uint32_t x, int byte_order)
{
if (byte_order == SCM_BYTE_ORDER)
return x;
else
return bswap_32 (x);
}
SCM
scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
#define FUNC_NAME "make-objcode-slice"
{
const struct scm_objcode *data, *parent_data;
const scm_t_uint8 *parent_base;
SCM_VALIDATE_OBJCODE (1, parent);
parent_data = SCM_OBJCODE_DATA (parent);
parent_base = SCM_C_OBJCODE_BASE (parent_data);
if (ptr < parent_base
|| ptr >= (parent_base + parent_data->len + parent_data->metalen
- sizeof (struct scm_objcode)))
scm_misc_error
(FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr),
scm_from_unsigned_integer ((scm_t_bits) parent_base),
scm_from_uint32 (parent_data->len),
scm_from_uint32 (parent_data->metalen)));
/* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
assert ((((scm_t_bits) ptr) &
(alignof_type (struct scm_objcode) - 1UL)) == 0);
data = (struct scm_objcode*) ptr;
assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
<= parent_base + parent_data->len + parent_data->metalen);
return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0),
(scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME
struct mapped_elf_image
{
@ -762,128 +681,6 @@ scm_all_mapped_elf_images (void)
return result;
}
/*
* Scheme interface
*/
SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_objcode_p
{
return scm_from_bool (SCM_OBJCODE_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
(SCM objcode),
"")
#define FUNC_NAME s_scm_objcode_meta
{
SCM_VALIDATE_OBJCODE (1, objcode);
if (SCM_OBJCODE_META_LEN (objcode) == 0)
return SCM_BOOL_F;
else
return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+ SCM_OBJCODE_LEN (objcode)));
}
#undef FUNC_NAME
/* Wrap BYTECODE in objcode, interpreting its lengths according to
BYTE_ORDER. */
static SCM
bytecode_to_objcode (SCM bytecode, int byte_order)
#define FUNC_NAME "bytecode->objcode"
{
size_t size, len, metalen;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
size = SCM_BYTEVECTOR_LENGTH (bytecode);
c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
len = to_native_order (data->len, byte_order);
metalen = to_native_order (data->metalen, byte_order);
if (len + metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + len + metalen)));
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0),
(scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 1, 0,
(SCM bytecode, SCM endianness),
"")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
int byte_order;
if (SCM_UNBNDP (endianness))
byte_order = SCM_BYTE_ORDER;
else if (scm_is_eq (endianness, scm_endianness_big))
byte_order = SCM_BYTE_ORDER_BE;
else if (scm_is_eq (endianness, scm_endianness_little))
byte_order = SCM_BYTE_ORDER_LE;
else
scm_wrong_type_arg (FUNC_NAME, 2, endianness);
return bytecode_to_objcode (bytecode, byte_order);
}
#undef FUNC_NAME
SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 1, 0,
(SCM objcode, SCM endianness),
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
scm_t_uint32 len, meta_len, total_len;
int byte_order;
SCM_VALIDATE_OBJCODE (1, objcode);
if (SCM_UNBNDP (endianness))
byte_order = SCM_BYTE_ORDER;
else if (scm_is_eq (endianness, scm_endianness_big))
byte_order = SCM_BYTE_ORDER_BE;
else if (scm_is_eq (endianness, scm_endianness_little))
byte_order = SCM_BYTE_ORDER_LE;
else
scm_wrong_type_arg (FUNC_NAME, 2, endianness);
len = SCM_OBJCODE_LEN (objcode);
meta_len = SCM_OBJCODE_META_LEN (objcode);
total_len = sizeof (struct scm_objcode);
total_len += to_native_order (len, byte_order);
total_len += to_native_order (meta_len, byte_order);
return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
total_len, objcode);
}
#undef FUNC_NAME
void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<objcode ", port);
scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
scm_puts_unlocked (">", port);
}
void
scm_bootstrap_objcodes (void)
@ -904,9 +701,6 @@ scm_init_objcodes (void)
(scm_t_subr) scm_find_mapped_elf_image);
scm_c_define_gsubr ("all-mapped-elf-images", 0, 0, 0,
(scm_t_subr) scm_all_mapped_elf_images);
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
}
/*

49
libguile/objcodes.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -21,56 +21,9 @@
#include <libguile.h>
/* Objcode data should be directly mappable to this C structure. */
struct scm_objcode
{
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
/* In C99, we'd have:
scm_t_uint8 base[]; */
};
/* Return a pointer to the base of objcode OBJ. */
#define SCM_C_OBJCODE_BASE(obj) \
((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
#define SCM_OBJCODE_TYPE_MMAP (0)
#define SCM_OBJCODE_TYPE_BYTEVECTOR (1)
#define SCM_OBJCODE_TYPE_SLICE (2)
#define SCM_OBJCODE_TYPE_STATIC (3)
#define SCM_OBJCODE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_objcode))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
#define SCM_MAKE_OBJCODE_TAG(type, flags) (scm_tc7_objcode | (type << 8) | (flags << 16))
#define SCM_OBJCODE_TYPE(x) ((SCM_CELL_WORD_0 (x) >> 8) & 0xff)
#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_MMAP)
#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_BYTEVECTOR)
#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_SLICE)
#define SCM_OBJCODE_IS_STATIC(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_STATIC)
#define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
#define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
SCM_API SCM scm_load_thunk_from_file (SCM filename);
SCM_API SCM scm_load_thunk_from_memory (SCM bv);
SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_objcode_p (SCM obj);
SCM_API SCM scm_objcode_meta (SCM objcode);
SCM_API SCM scm_bytecode_to_objcode (SCM bytecode, SCM endianness);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode, SCM endianness);
SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_objcodes (void);
SCM_INTERNAL void scm_init_objcodes (void);

4
libguile/print.c
View file

@ -661,7 +661,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
scm_i_variable_print (exp, port, pstate);
break;
case scm_tc7_rtl_program:
case scm_tc7_program:
scm_i_program_print (exp, port, pstate);
break;
case scm_tc7_pointer:
@ -685,9 +684,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_frame:
scm_i_frame_print (exp, port, pstate);
break;
case scm_tc7_objcode:
scm_i_objcode_print (exp, port, pstate);
break;
case scm_tc7_vm:
scm_i_vm_print (exp, port, pstate);
break;

11
libguile/procprop.c
View file

@ -61,7 +61,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return 1;
}
while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc))
while (!SCM_RTL_PROGRAM_P (proc))
{
if (SCM_STRUCTP (proc))
{
@ -146,9 +146,7 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
return scm_cdr (user_props);
if (SCM_PROGRAM_P (proc))
ret = scm_i_program_properties (proc);
else if (SCM_RTL_PROGRAM_P (proc))
if (SCM_RTL_PROGRAM_P (proc))
ret = scm_i_rtl_program_properties (proc);
else
ret = SCM_EOL;
@ -262,8 +260,6 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
if (SCM_RTL_PROGRAM_P (proc))
return scm_i_rtl_program_name (proc);
else if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
else
@ -301,9 +297,6 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
if (SCM_RTL_PROGRAM_P (proc))
return scm_i_rtl_program_documentation (proc);
else if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_i_program_properties (proc),
scm_sym_documentation);
else
return SCM_BOOL_F;
}

3
libguile/procs.c
View file

@ -47,8 +47,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
return scm_from_bool (SCM_PROGRAM_P (obj)
|| SCM_RTL_PROGRAM_P (obj)
return scm_from_bool (SCM_RTL_PROGRAM_P (obj)
|| (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
|| (SCM_HAS_TYP7 (obj, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (obj)));

305
libguile/programs.c
View file

@ -22,53 +22,14 @@
#include <string.h>
#include "_scm.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
#include "procprop.h" /* scm_sym_name */
#include "srcprop.h" /* scm_sym_filename */
#include "vm.h"
static SCM write_program = SCM_BOOL_F;
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
(SCM objcode, SCM objtable, SCM free_variables),
"")
#define FUNC_NAME s_scm_make_program
{
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_UNBNDP (free_variables) || scm_is_false (free_variables))
{
SCM ret = scm_words (scm_tc7_program, 3);
SCM_SET_CELL_OBJECT_1 (ret, objcode);
SCM_SET_CELL_OBJECT_2 (ret, objtable);
return ret;
}
else
{
size_t i, len;
SCM ret;
SCM_VALIDATE_VECTOR (3, free_variables);
len = scm_c_vector_length (free_variables);
if (SCM_UNLIKELY (len >> 16))
SCM_OUT_OF_RANGE (3, free_variables);
ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
SCM_SET_CELL_OBJECT_1 (ret, objcode);
SCM_SET_CELL_OBJECT_2 (ret, objtable);
for (i = 0; i < len; i++)
SCM_SET_CELL_OBJECT (ret, 3+i,
SCM_SIMPLE_VECTOR_REF (free_variables, i));
return ret;
}
}
#undef FUNC_NAME
SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2, 0,
(SCM bytevector, SCM byte_offset, SCM free_variables),
"")
@ -185,8 +146,6 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
scm_putc_unlocked ('>', port);
}
else if (scm_is_false (write_program) || print_error)
{
if (SCM_RTL_PROGRAM_P (program))
{
scm_puts_unlocked ("#<rtl-program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
@ -194,13 +153,6 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
scm_putc_unlocked ('>', port);
}
else
{
scm_puts_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc_unlocked ('>', port);
}
}
else
{
print_error = 1;
@ -214,15 +166,6 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
* Scheme interface
*/
SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_program_p
{
return scm_from_bool (SCM_PROGRAM_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
(SCM obj),
"")
@ -252,152 +195,6 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_base
{
const struct scm_objcode *c_objcode;
SCM_VALIDATE_PROGRAM (1, program);
c_objcode = SCM_PROGRAM_DATA (program);
return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode));
}
#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, mod;
SCM_VALIDATE_PROGRAM (1, program);
objs = SCM_PROGRAM_OBJTABLE (program);
/* If a program is the result of compiling GLIL to assembly, then if
it has an objtable, the first entry will be a module. But some
programs are hand-coded trampolines, like boot programs and
primitives and the like. So if a program happens to have a
non-module in the first slot of the objtable, assume that it is
such a trampoline, and just return #f for the module. */
mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
return SCM_MODULEP (mod) ? mod : SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_meta
{
SCM metaobj;
SCM_VALIDATE_PROGRAM (1, program);
metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
if (scm_is_true (metaobj))
return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
SCM_BOOL_F);
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_bindings
{
SCM meta;
SCM_VALIDATE_PROGRAM (1, program);
meta = scm_program_meta (program);
if (scm_is_false (meta))
return SCM_BOOL_F;
return scm_car (scm_call_0 (meta));
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_sources, "%program-sources", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_sources
{
SCM meta, sources, ret, filename;
SCM_VALIDATE_PROGRAM (1, program);
meta = scm_program_meta (program);
if (scm_is_false (meta))
return SCM_EOL;
filename = SCM_BOOL_F;
ret = SCM_EOL;
for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
sources = scm_cdr (sources))
{
SCM x = scm_car (sources);
if (scm_is_pair (x))
{
if (scm_is_number (scm_car (x)))
{
SCM addr = scm_car (x);
ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
ret);
}
else if (scm_is_eq (scm_car (x), scm_sym_filename))
filename = scm_cdr (x);
}
}
return scm_reverse_x (ret, SCM_UNDEFINED);
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_arities
{
SCM meta;
SCM_VALIDATE_PROGRAM (1, program);
meta = scm_program_meta (program);
if (scm_is_false (meta))
return SCM_BOOL_F;
return scm_caddr (scm_call_0 (meta));
}
#undef FUNC_NAME
SCM
scm_i_program_properties (SCM program)
#define FUNC_NAME "%program-properties"
{
SCM meta;
SCM_VALIDATE_PROGRAM (1, program);
meta = scm_program_meta (program);
if (scm_is_false (meta))
return SCM_EOL;
return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
SCM
scm_find_source_for_addr (SCM ip)
{
@ -438,12 +235,9 @@ SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0,
"")
#define FUNC_NAME s_scm_program_num_free_variables
{
if (SCM_RTL_PROGRAM_P (program)) {
return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program));
}
SCM_VALIDATE_RTL_PROGRAM (1, program);
SCM_VALIDATE_PROGRAM (1, program);
return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program));
}
#undef FUNC_NAME
@ -454,19 +248,12 @@ SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
{
unsigned long idx;
if (SCM_RTL_PROGRAM_P (program)) {
SCM_VALIDATE_RTL_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx);
}
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
@ -476,62 +263,17 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0,
{
unsigned long idx;
if (SCM_RTL_PROGRAM_P (program)) {
SCM_VALIDATE_RTL_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
return SCM_UNSPECIFIED;
}
SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
(SCM program),
"Return a @var{program}'s object code.")
#define FUNC_NAME s_scm_program_objcode
{
SCM_VALIDATE_PROGRAM (1, program);
return SCM_PROGRAM_OBJCODE (program);
}
#undef FUNC_NAME
/* procedure-minimum-arity support. */
static void
parse_arity (SCM arity, int *req, int *opt, int *rest)
{
SCM x = scm_cddr (arity);
if (scm_is_pair (x))
{
*req = scm_to_int (scm_car (x));
x = scm_cdr (x);
if (scm_is_pair (x))
{
*opt = scm_to_int (scm_car (x));
x = scm_cdr (x);
if (scm_is_pair (x))
*rest = scm_is_true (scm_car (x));
else
*rest = 0;
}
else
*opt = *rest = 0;
}
else
*req = *opt = *rest = 0;
}
static int
scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
static SCM rtl_program_minimum_arity = SCM_BOOL_F;
SCM l;
@ -566,41 +308,6 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
return 1;
}
int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
SCM arities;
if (SCM_RTL_PROGRAM_P (program))
return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
arities = scm_program_arities (program);
if (!scm_is_pair (arities))
return 0;
parse_arity (scm_car (arities), req, opt, rest);
arities = scm_cdr (arities);
for (; scm_is_pair (arities); arities = scm_cdr (arities))
{
int thisreq, thisopt, thisrest;
parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);
if (thisreq < *req
|| (thisreq == *req
&& ((thisrest && (!*rest || thisopt > *opt))
|| (!thisrest && !*rest && thisopt > *opt))))
{
*req = thisreq;
*opt = thisopt;
*rest = thisrest;
}
}
return 1;
}
void

22
libguile/programs.h
View file

@ -20,7 +20,6 @@
#define _SCM_PROGRAMS_H_
#include <libguile.h>
#include <libguile/objcodes.h>
/*
* The new RTL programs.
@ -64,15 +63,6 @@ SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip);
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3))
#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v))
#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
#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)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
@ -80,23 +70,11 @@ SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip);
#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
#define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_FOREIGN)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip, SCM sources);
SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_objects (SCM program);
SCM_API SCM scm_program_module (SCM program);
SCM_API SCM scm_program_num_free_variables (SCM program);
SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i);
SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x);
SCM_API SCM scm_program_objcode (SCM program);
SCM_INTERNAL SCM scm_i_program_properties (SCM program);
SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate);

1
libguile/smob.c
View file

@ -32,7 +32,6 @@
#include "libguile/async.h"
#include "libguile/goops.h"
#include "libguile/instructions.h"
#include "libguile/objcodes.h"
#include "libguile/programs.h"
#include "libguile/smob.h"

21
libguile/snarf.h
View file

@ -325,27 +325,6 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
static SCM_ALIGNED (8) SCM c_name[3] = \
{ \
SCM_PACK (scm_tc7_vector | (2 << 8)), \
foreign, \
SCM_BOOL_F /* the name */ \
}
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
static SCM_ALIGNED (8) SCM_UNUSED SCM \
scm_i_paste (c_name, _raw_cell)[] = \
{ \
SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \
objcode, \
objtable, \
freevars \
}; \
static SCM_UNUSED const SCM c_name = \
SCM_PACK (& scm_i_paste (c_name, _raw_cell))
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */

3
libguile/stacks.c
View file

@ -276,8 +276,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* FIXME: is this even possible? */
if (scm_is_true (frame)
&& (SCM_PROGRAM_P (scm_frame_procedure (frame))
|| SCM_RTL_PROGRAM_P (scm_frame_procedure (frame)))
&& SCM_RTL_PROGRAM_P (scm_frame_procedure (frame))
&& SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
frame = scm_frame_previous (frame);

4
libguile/tags.h
View file

@ -423,14 +423,14 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define scm_tc7_dynamic_state 45
#define scm_tc7_frame 47
#define scm_tc7_objcode 53
#define scm_tc7_unused_53 53
#define scm_tc7_vm 55
#define scm_tc7_vm_cont 71
#define scm_tc7_unused_17 61
#define scm_tc7_unused_21 63
#define scm_tc7_rtl_program 69
#define scm_tc7_program 79
#define scm_tc7_unused_79 79
#define scm_tc7_weak_set 85
#define scm_tc7_weak_table 87
#define scm_tc7_array 93

430
libguile/vm-engine.c
View file

@ -19,32 +19,6 @@
/* This file is included in vm.c multiple times. */
/* Virtual Machine
This file contains two virtual machines. First, the old one -- the
one that is currently used, and corresponds to Guile 2.0. It's a
stack machine, meaning that most instructions pop their operands from
the top of the stack, and push results there too.
Following it is the new virtual machine. It's a register machine,
meaning that intructions address their operands by index, and store
results in indexed slots as well. Those slots are on the stack.
It's somewhat confusing to call it a register machine, given that the
values are on the stack. Perhaps it needs a new name.
Anyway, things are in a transitional state. We're going to try to
avoid munging the old VM very much while we flesh out the new one.
We're also going to try to make them interoperable, as much as
possible -- to have the old VM be able to call procedures for the new
VM, and vice versa. This should ease the bootstrapping process. */
/* The old VM. */
static SCM VM_NAME (SCM, SCM, SCM*, int);
/* The new VM. */
static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
# define VM_USE_HOOKS 0 /* Various hooks */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
@ -70,9 +44,6 @@ static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
#ifndef IP_REG
# define IP_REG
#endif
#ifndef SP_REG
# define SP_REG
#endif
#ifndef FP_REG
# define FP_REG
#endif
@ -126,393 +97,6 @@ static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
/* Cache the VM's instruction, stack, and frame pointer in local variables. */
#define CACHE_REGISTER() \
{ \
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
}
/* Update the registers in VP, a pointer to the current VM. This must be done
at least before any GC invocation so that `vp->sp' is up-to-date and the
whole stack gets marked. */
#define SYNC_REGISTER() \
{ \
vp->ip = ip; \
vp->sp = sp; \
vp->fp = fp; \
}
/* FIXME */
#define ASSERT_VARIABLE(x) \
VM_ASSERT (SCM_VARIABLEP (x), abort())
#define ASSERT_BOUND_VARIABLE(x) \
VM_ASSERT (SCM_VARIABLEP (x) \
&& !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \
abort())
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
#define ASSERT_ALIGNED_PROCEDURE() \
do { if ((scm_t_bits)bp % 8) abort (); } while (0)
#define ASSERT_BOUND(x) \
VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
#else
#define CHECK_IP()
#define ASSERT_ALIGNED_PROCEDURE()
#define ASSERT_BOUND(x)
#endif
/* Cache the object table and free variables. */
#define CACHE_PROGRAM() \
{ \
if (bp != SCM_PROGRAM_DATA (program)) { \
bp = SCM_PROGRAM_DATA (program); \
ASSERT_ALIGNED_PROCEDURE (); \
if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
} else { \
objects = NULL; \
} \
} \
}
#define SYNC_BEFORE_GC() \
{ \
SYNC_REGISTER (); \
}
#define SYNC_ALL() \
{ \
SYNC_REGISTER (); \
}
/*
* Error check
*/
/* Accesses to a program's object table. */
#define CHECK_OBJECT(_num)
#define CHECK_FREE_VARIABLE(_num)
/*
* Stack operation
*/
#ifdef VM_ENABLE_STACK_NULLING
# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
that continuation doesn't have a chance to run. It's not important on a
semantic level, but it does mess up our stack nulling -- so this macro is to
fix that. */
# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
#else
# define CHECK_STACK_LEAKN(_n)
# define CHECK_STACK_LEAK()
# define NULLSTACK(_n)
# define NULLSTACK_FOR_NONLOCAL_EXIT()
#endif
/* For this check, we don't use VM_ASSERT, because that leads to a
per-site SYNC_ALL, which is too much code growth. The real problem
of course is having to check for overflow all the time... */
#define CHECK_OVERFLOW() \
do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
#ifdef VM_CHECK_UNDERFLOW
#define PRE_CHECK_UNDERFLOW(N) \
VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
#else
#define PRE_CHECK_UNDERFLOW(N) /* nop */
#define CHECK_UNDERFLOW() /* nop */
#endif
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
/* Pop the N objects on top of the stack and push a list that contains
them. */
#define POP_LIST(n) \
do \
{ \
int i; \
SCM l = SCM_EOL, x; \
SYNC_BEFORE_GC (); \
for (i = n; i; i--) \
{ \
POP (x); \
l = scm_cons (x, l); \
} \
PUSH (l); \
} while (0)
/* The opposite: push all of the elements in L onto the list. */
#define PUSH_LIST(l, NILP) \
do \
{ \
for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \
VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
} while (0)
/*
* Instruction operation
*/
#define FETCH() (*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
#undef NEXT_JUMP
#ifdef HAVE_LABELS_AS_VALUES
# define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
#else
# define NEXT_JUMP() goto vm_start
#endif
#define NEXT \
{ \
NEXT_HOOK (); \
CHECK_STACK_LEAK (); \
NEXT_JUMP (); \
}
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
and the arguments are already on the stack */
#define DROP_FRAME() \
{ \
sp -= 3; \
NULLSTACK (3); \
CHECK_UNDERFLOW (); \
}
static SCM
VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
{
/* VM registers */
register scm_t_uint8 *ip IP_REG; /* instruction pointer */
register SCM *sp SP_REG; /* stack pointer */
register SCM *fp FP_REG; /* frame pointer */
struct scm_vm *vp = SCM_VM_DATA (vm);
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
SCM *objects = NULL; /* constant objects */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
/* Internal variables */
int nvalues = 0;
scm_i_jmp_buf registers; /* used for prompts */
#ifdef HAVE_LABELS_AS_VALUES
static const void **jump_table_pointer = NULL;
#endif
#ifdef HAVE_LABELS_AS_VALUES
register const void **jump_table JT_REG;
if (SCM_UNLIKELY (!jump_table_pointer))
{
int i;
jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
jump_table_pointer[i] = &&vm_error_bad_instruction;
#define VM_INSTRUCTION_TO_LABEL 1
#define jump_table jump_table_pointer
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef jump_table
#undef VM_INSTRUCTION_TO_LABEL
}
/* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
load instruction at each instruction dispatch. */
jump_table = jump_table_pointer;
#endif
if (SCM_I_SETJMP (registers))
{
/* Non-local return. Cache the VM registers back from the vp, and
go to the handler.
Note, at this point, we must assume that any variable local to
vm_engine that can be assigned *has* been assigned. So we need to pull
all our state back from the ip/fp/sp.
*/
CACHE_REGISTER ();
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
/* The stack contains the values returned to this continuation,
along with a number-of-values marker -- like an MV return. */
ABORT_CONTINUATION_HOOK (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp));
NEXT;
}
CACHE_REGISTER ();
/* Since it's possible to receive the arguments on the stack itself,
and indeed the RTL VM invokes us that way, shuffle up the
arguments first. */
VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs));
{
int i;
for (i = nargs - 1; i >= 0; i--)
sp[9 + i] = argv[i];
}
/* Initial frame */
PUSH (SCM_PACK (fp)); /* dynamic link */
PUSH (SCM_PACK (0)); /* mvra */
PUSH (SCM_PACK (ip)); /* ra */
PUSH (boot_continuation);
fp = sp + 1;
ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
/* MV-call frame, function & arguments */
PUSH (SCM_PACK (fp)); /* dynamic link */
PUSH (SCM_PACK (ip + 1)); /* mvra */
PUSH (SCM_PACK (ip)); /* ra */
PUSH (program);
fp = sp + 1;
sp += nargs;
PUSH_CONTINUATION_HOOK ();
apply:
program = fp[-1];
if (!SCM_PROGRAM_P (program))
{
if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
fp[-1] = SCM_STRUCT_PROCEDURE (program);
else if (SCM_HAS_TYP7 (program, scm_tc7_rtl_program))
{
SCM ret;
SYNC_ALL ();
ret = RTL_VM_NAME (vm, program, fp, sp - fp + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
/* multiple values returned to continuation */
ret = scm_struct_ref (ret, SCM_INUM0);
nvalues = scm_ilength (ret);
PUSH_LIST (ret, scm_is_null);
goto vm_return_values;
}
else
{
PUSH (ret);
goto vm_return;
}
}
else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
/* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
int i;
PUSH (SCM_BOOL_F);
for (i = sp - fp; i >= 0; i--)
fp[i] = fp[i - 1];
fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
}
else
{
SYNC_ALL();
vm_error_wrong_type_apply (program);
}
goto apply;
}
CACHE_PROGRAM ();
ip = SCM_C_OBJCODE_BASE (bp);
APPLY_HOOK ();
/* Let's go! */
NEXT;
#ifndef HAVE_LABELS_AS_VALUES
vm_start:
switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
#endif
#include "vm-expand.h"
#include "vm-i-system.c"
#include "vm-i-scheme.c"
#include "vm-i-loader.c"
#ifndef HAVE_LABELS_AS_VALUES
default:
goto vm_error_bad_instruction;
}
#endif
abort (); /* never reached */
vm_error_bad_instruction:
vm_error_bad_instruction (ip[-1]);
abort (); /* never reached */
handle_overflow:
SYNC_ALL ();
vm_error_stack_overflow (vp);
abort (); /* never reached */
}
#undef ALIGNED_P
#undef CACHE_REGISTER
#undef CHECK_OVERFLOW
#undef FUNC2
#undef INIT
#undef INUM_MAX
#undef INUM_MIN
#undef INUM_STEP
#undef jump_table
#undef LOCAL_REF
#undef LOCAL_SET
#undef NEXT
#undef NEXT_JUMP
#undef REL
#undef RETURN
#undef RETURN_ONE_VALUE
#undef RETURN_VALUE_LIST
#undef SYNC_ALL
#undef SYNC_BEFORE_GC
#undef SYNC_IP
#undef SYNC_REGISTER
#undef VARIABLE_BOUNDP
#undef VARIABLE_REF
#undef VARIABLE_SET
#undef VM_DEFINE_OP
#undef VM_INSTRUCTION_TO_LABEL
/* Virtual Machine
This is Guile's new virtual machine. When I say "new", I mean
@ -918,22 +502,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
continue;
}
#if 0
SYNC_IP();
vm_error_wrong_type_apply (proc);
#else
{
SCM ret;
SYNC_ALL ();
ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
if (SCM_UNLIKELY (SCM_VALUESP (ret)))
RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
else
RETURN_ONE_VALUE (ret);
}
#endif
}
/* Let's go! */

134
libguile/vm-i-loader.c
View file

@ -1,134 +0,0 @@
/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
*
* 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 3 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
*/
/* FIXME! Need to check that the fetch is within the current program */
/* This file is included in vm_engine.c */
VM_DEFINE_LOADER (101, load_number, "load-number")
{
size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
SCM_UNDEFINED /* radix = 10 */));
/* Was: scm_istring2number (ip, len, 10)); */
ip += len;
NEXT;
}
VM_DEFINE_LOADER (102, load_string, "load-string")
{
size_t len;
char *buf;
FETCH_LENGTH (len);
SYNC_REGISTER ();
PUSH (scm_i_make_string (len, &buf, 1));
memcpy (buf, (char *) ip, len);
ip += len;
NEXT;
}
VM_DEFINE_LOADER (103, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
/* FIXME: should be scm_from_latin1_symboln */
PUSH (scm_from_latin1_symboln ((const char*)ip, len));
ip += len;
NEXT;
}
VM_DEFINE_LOADER (104, load_program, "load-program")
{
scm_t_uint32 len;
SCM objs, objcode;
POP (objs);
SYNC_REGISTER ();
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_TOTAL_LEN (objcode);
PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));
ip += len;
NEXT;
}
VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1)
{
SCM what;
POP (what);
SYNC_REGISTER ();
PUSH (resolve_variable (what, scm_current_module ()));
NEXT;
}
VM_DEFINE_LOADER (106, load_array, "load-array")
{
SCM type, shape;
size_t len;
FETCH_LENGTH (len);
POP2 (shape, type);
SYNC_REGISTER ();
PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
ip += len;
NEXT;
}
VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
{
size_t len;
scm_t_wchar *wbuf;
FETCH_LENGTH (len);
VM_ASSERT ((len % 4) == 0,
vm_error_bad_wide_string_length (len));
SYNC_REGISTER ();
PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
memcpy ((char *) wbuf, (char *) ip, len);
ip += len;
NEXT;
}
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
(let ((counter 100)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
t t nil 1)))))
*/
/*
Local Variables:
c-file-style: "gnu"
End:
*/

1126
libguile/vm-i-scheme.c
View file

File diff suppressed because it is too large Load diff

1656
libguile/vm-i-system.c
View file

File diff suppressed because it is too large Load diff

40
libguile/vm.c
View file

@ -603,8 +603,6 @@ vm_error_bad_wide_string_length (size_t len)
static SCM boot_continuation;
static SCM rtl_boot_continuation;
static SCM vm_builtin_apply;
static SCM vm_builtin_values;
@ -768,29 +766,22 @@ initialize_default_stack_size (void)
vm_stack_size = size;
}
#define VM_NAME vm_regular_engine
#define RTL_VM_NAME rtl_vm_regular_engine
#define FUNC_NAME "vm-regular-engine"
#define VM_ENGINE SCM_VM_REGULAR_ENGINE
#include "vm-engine.c"
#undef VM_NAME
#undef RTL_VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE
#define VM_NAME vm_debug_engine
#define RTL_VM_NAME rtl_vm_debug_engine
#define FUNC_NAME "vm-debug-engine"
#define VM_ENGINE SCM_VM_DEBUG_ENGINE
#include "vm-engine.c"
#undef VM_NAME
#undef RTL_VM_NAME
#undef FUNC_NAME
#undef VM_ENGINE
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs);
static const scm_t_rtl_vm_engine rtl_vm_engines[] =
@ -879,9 +870,6 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
SCM_CHECK_STACK;
if (SCM_PROGRAM_P (program))
return vm_engines[vp->engine](vm, program, argv, nargs);
else
return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
}
@ -1196,32 +1184,6 @@ SCM scm_load_compiled_with_vm (SCM file)
}
static SCM
make_boot_program (void)
{
struct scm_objcode *bp;
size_t bp_size;
SCM u8vec, ret;
const scm_t_uint8 text[] = {
scm_op_make_int8_1,
scm_op_halt
};
bp_size = sizeof (struct scm_objcode) + sizeof (text);
bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
bp->len = sizeof(text);
bp->metalen = 0;
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F);
ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
return ret;
}
void
scm_init_vm_builtin_properties (void)
{
@ -1263,8 +1225,6 @@ scm_bootstrap_vm (void)
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
boot_continuation = make_boot_program ();
rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
(SCM_CELL_WORD_0 (rtl_boot_continuation)

3
module/ice-9/session.scm
View file

@ -522,8 +522,7 @@ The alist keys that are currently defined are `required', `optional',
(rest . ,rest)))))
((procedure-source proc)
=> cadr)
((or ((@ (system vm program) program?) proc)
((@ (system vm program) rtl-program?) proc))
(((@ (system vm program) rtl-program?) proc)
((@ (system vm program) program-arguments-alist) proc))
(else #f)))

2
module/language/tree-il/analyze.scm
View file

@ -950,7 +950,7 @@ given `tree-il' element."
(or (and (or (null? x) (pair? x))
(length x))
0))
(cond ((or (program? proc) (rtl-program? proc))
(cond ((rtl-program? proc)
(values (procedure-name proc)
(map (lambda (a)
(list (length (or (assq-ref a 'required) '()))

3
module/statprof.scm
View file

@ -217,7 +217,6 @@
(define (get-call-data proc)
(let ((k (cond
((program? proc) (program-objcode proc))
((rtl-program? proc) (rtl-program-code proc))
(else proc))))
(or (hashv-ref procedure-data k)
@ -581,8 +580,6 @@ to @code{statprof-reset} is true."
(lambda (a b)
(cond
((eq? a b))
((and (program? a) (program? b))
(eq? (program-objcode a) (program-objcode b)))
((and (rtl-program? a) (rtl-program? b))
(eq? (rtl-program-code a) (rtl-program-code b)))
(else

3
module/system/repl/debug.scm
View file

@ -170,7 +170,8 @@
;; Patches welcome!
(define (frame->module frame)
(let ((proc (frame-procedure frame)))
(if (program? proc)
(if #f
;; FIXME!
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)

6
module/system/vm/frame.scm
View file

@ -31,9 +31,7 @@
(define (frame-bindings frame)
(let ((p (frame-procedure frame)))
(if (program? p)
(program-bindings-for-ip p (frame-instruction-pointer frame))
'())))
(program-bindings-for-ip p (frame-instruction-pointer frame))))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
@ -90,7 +88,7 @@
(cons
(or (false-if-exception (procedure-name p)) p)
(cond
((and (or (program? p) (rtl-program? p))
((and (rtl-program? p)
(program-arguments-alist p (frame-instruction-pointer frame)))
;; case 1
=> (lambda (arguments)

8
module/system/vm/instruction.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM instructions
;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2010, 2012, 2013 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -19,11 +19,7 @@
;;; Code:
(define-module (system vm instruction)
#:export (rtl-instruction-list
instruction-list
instruction? instruction-length
instruction-pops instruction-pushes
instruction->opcode opcode->instruction))
#:export (rtl-instruction-list))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_instructions")

44
module/system/vm/program.scm
View file

@ -25,8 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (make-program
make-rtl-program
#:export (make-rtl-program
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
@ -35,7 +34,8 @@
source:line-for-user
program-sources program-sources-pre-retire program-source
program-bindings program-bindings-by-index program-bindings-for-ip
program-bindings-for-ip
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
@ -43,10 +43,7 @@
program-arguments-alist program-arguments-alists
program-lambda-list
program-meta
program-objcode program? program-objects
rtl-program? rtl-program-code
program-module program-base
program-free-variables
program-num-free-variables
program-free-variable-ref program-free-variable-set!))
@ -96,29 +93,6 @@
(define (source:line-for-user source)
(1+ (source:line source)))
;; FIXME: pull this definition from elsewhere.
(define *bytecode-header-len* 8)
;; We could decompile the program to get this, but that seems like a
;; waste.
(define (bytecode-instruction-length bytecode ip)
(let* ((idx (+ ip *bytecode-header-len*))
(inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
;; 1+ for the instruction itself.
(1+ (cond
((eq? inst 'load-program)
(+ (bytevector-u32-native-ref bytecode (+ idx 1))
(bytevector-u32-native-ref bytecode (+ idx 5))))
((< (instruction-length inst) 0)
;; variable length instruction -- the length is encoded in the
;; instruction stream.
(+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
(ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
(bytevector-u8-ref bytecode (+ idx 3))))
(else
;; fixed length
(instruction-length inst))))))
(define (source-for-addr addr)
(and=> (find-source-for-addr addr)
(lambda (source)
@ -129,16 +103,12 @@
(source-column source)))))
(define (program-sources proc)
(cond
((rtl-program? proc)
(map (lambda (source)
(cons* (- (source-post-pc source) (rtl-program-code proc))
(source-file source)
(source-line source)
(source-column source)))
(find-program-sources (rtl-program-code proc))))
(else
(%program-sources proc))))
(define* (program-source proc ip #:optional (sources (program-sources proc)))
(let lp ((source #f) (sources sources))
@ -185,9 +155,8 @@
;; returns list of list of bindings
;; (list-ref ret N) == bindings bound to the Nth local slot
(define (program-bindings-by-index prog)
(cond ((rtl-program? prog) '())
((program-bindings prog) => collapse-locals)
(else '())))
;; FIXME!
'())
(define (program-bindings-for-ip prog ip)
(let lp ((in (program-bindings-by-index prog)) (out '()))
@ -343,9 +312,6 @@ lists."
(if arities
(map arity-arguments-alist arities)
(fallback))))
((program? prog)
(map (lambda (arity) (arity->arguments-alist prog arity))
(or (program-arities prog) '())))
(else (error "expected a program" prog))))
(define (write-program prog port)