summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-08 18:28:24 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-08 18:28:24 +0100
commit1c33be992e8120abd20add8021e4d91d226f5b6a (patch)
tree71f78961b6a29aa1e342049419f402af555e6f20
parent84680d238299c3b2c8be42b16a8be0ff6e02ba5c (diff)
downloadguile-1c33be992e8120abd20add8021e4d91d226f5b6a.tar.gz
Remove stack programs, objcode, and the old VM.
* 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.
-rw-r--r--libguile/Makefile.am10
-rw-r--r--libguile/_scm.h7
-rw-r--r--libguile/evalext.c4
-rw-r--r--libguile/frames.c30
-rw-r--r--libguile/gc.c2
-rw-r--r--libguile/goops.c11
-rw-r--r--libguile/instructions.c162
-rw-r--r--libguile/instructions.h17
-rw-r--r--libguile/objcodes.c206
-rw-r--r--libguile/objcodes.h49
-rw-r--r--libguile/print.c4
-rw-r--r--libguile/procprop.c11
-rw-r--r--libguile/procs.c3
-rw-r--r--libguile/programs.c323
-rw-r--r--libguile/programs.h22
-rw-r--r--libguile/smob.c1
-rw-r--r--libguile/snarf.h21
-rw-r--r--libguile/stacks.c3
-rw-r--r--libguile/tags.h4
-rw-r--r--libguile/vm-engine.c430
-rw-r--r--libguile/vm-i-loader.c134
-rw-r--r--libguile/vm-i-scheme.c1126
-rw-r--r--libguile/vm-i-system.c1656
-rw-r--r--libguile/vm.c42
-rw-r--r--module/ice-9/session.scm3
-rw-r--r--module/language/tree-il/analyze.scm2
-rw-r--r--module/statprof.scm3
-rw-r--r--module/system/repl/debug.scm3
-rw-r--r--module/system/vm/frame.scm6
-rw-r--r--module/system/vm/instruction.scm8
-rw-r--r--module/system/vm/program.scm56
31 files changed, 51 insertions, 4308 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index e3a9e00ce..b2a9faf3a 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -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
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 1ec93fbb4..7afb5a11f 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -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 */
/*
diff --git a/libguile/evalext.c b/libguile/evalext.c
index f955cee7f..897cabe44 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -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:
diff --git a/libguile/frames.c b/libguile/frames.c
index d32f8374c..ce671b889 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -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);
+ /* 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);
}
#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;
diff --git a/libguile/gc.c b/libguile/gc.c
index 581bbc527..dfec8d5a3 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -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:
diff --git a/libguile/goops.c b/libguile/goops.c
index 49840bf4a..1f56d34c7 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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>",
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 43937d76a..3dc15c2ff 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -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)
{
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 63bff7ae7..fc9bce8ee 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -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);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index fa4e28b39..358a1e77a 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -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
{
@@ -763,128 +682,6 @@ scm_all_mapped_elf_images (void)
}
-/*
- * 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));
}
/*
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 6ac333fa4..2d439f7b4 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -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);
diff --git a/libguile/print.c b/libguile/print.c
index a77f1a8b4..2091539a6 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -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;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 5bb9e6259..488edcc7c 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -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;
}
diff --git a/libguile/procs.c b/libguile/procs.c
index b02182427..bf965ee58 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -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)));
diff --git a/libguile/programs.c b/libguile/programs.c
index f74e4ed5c..a2c3fc90b 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -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),
"")
@@ -186,20 +147,11 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
}
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);
- scm_putc_unlocked (' ', port);
- 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);
- }
+ scm_puts_unlocked ("#<rtl-program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
+ scm_putc_unlocked ('>', port);
}
else
{
@@ -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,18 +248,11 @@ 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_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_RTL_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
- return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
+ return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx);
}
#undef FUNC_NAME
@@ -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_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_RTL_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
SCM_OUT_OF_RANGE (2, i);
- SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+ SCM_RTL_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
diff --git a/libguile/programs.h b/libguile/programs.h
index 0d33957a5..4b28b6e75 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -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);
diff --git a/libguile/smob.c b/libguile/smob.c
index 857773c18..e13591f0f 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -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"
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 7843ac8da..afc4d8f2a 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -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 */
diff --git a/libguile/stacks.c b/libguile/stacks.c
index fd19a492a..bbdde3026 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -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);
diff --git a/libguile/tags.h b/libguile/tags.h
index 9e6943ed0..1c6503a4f 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -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
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 567bdbc3b..d657a08bd 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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! */
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
deleted file mode 100644
index c3231568e..000000000
--- a/libguile/vm-i-loader.c
+++ /dev/null
@@ -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:
-*/
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
deleted file mode 100644
index 07bb6442d..000000000
--- a/libguile/vm-i-scheme.c
+++ /dev/null
@@ -1,1126 +0,0 @@
-/* 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
- * 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
- */
-
-/* This file is included in vm_engine.c */
-
-
-/*
- * Predicates
- */
-
-#define ARGS1(a1) SCM a1 = sp[0];
-#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
-#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
-
-#define RETURN(x) do { *sp = x; NEXT; } while (0)
-
-VM_DEFINE_FUNCTION (128, not, "not", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_false (x)));
-}
-
-VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_false (x)));
-}
-
-VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
-{
- ARGS2 (x, y);
- RETURN (scm_from_bool (scm_is_eq (x, y)));
-}
-
-VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
-{
- ARGS2 (x, y);
- RETURN (scm_from_bool (!scm_is_eq (x, y)));
-}
-
-VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_null (x)));
-}
-
-VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_null (x)));
-}
-
-VM_DEFINE_FUNCTION (134, nilp, "nil?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_lisp_false (x)));
-}
-
-VM_DEFINE_FUNCTION (135, not_nilp, "not-nil?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_lisp_false (x)));
-}
-
-VM_DEFINE_FUNCTION (136, eqv, "eqv?", 2)
-{
- ARGS2 (x, y);
- if (scm_is_eq (x, y))
- RETURN (SCM_BOOL_T);
- if (SCM_IMP (x) || SCM_IMP (y))
- RETURN (SCM_BOOL_F);
- SYNC_REGISTER ();
- RETURN (scm_eqv_p (x, y));
-}
-
-VM_DEFINE_FUNCTION (137, equal, "equal?", 2)
-{
- ARGS2 (x, y);
- if (scm_is_eq (x, y))
- RETURN (SCM_BOOL_T);
- if (SCM_IMP (x) || SCM_IMP (y))
- RETURN (SCM_BOOL_F);
- SYNC_REGISTER ();
- RETURN (scm_equal_p (x, y));
-}
-
-VM_DEFINE_FUNCTION (138, pairp, "pair?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_pair (x)));
-}
-
-VM_DEFINE_FUNCTION (139, listp, "list?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_ilength (x) >= 0));
-}
-
-VM_DEFINE_FUNCTION (140, symbolp, "symbol?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_symbol (x)));
-}
-
-VM_DEFINE_FUNCTION (141, vectorp, "vector?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
-}
-
-
-/*
- * Basic data
- */
-
-VM_DEFINE_FUNCTION (142, cons, "cons", 2)
-{
- ARGS2 (x, y);
- SYNC_BEFORE_GC ();
- x = scm_cons (x, y);
- RETURN (x);
-}
-
-#define VM_VALIDATE_CONS(x, proc) \
- VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
-
-VM_DEFINE_FUNCTION (143, car, "car", 1)
-{
- ARGS1 (x);
- VM_VALIDATE_CONS (x, "car");
- RETURN (SCM_CAR (x));
-}
-
-VM_DEFINE_FUNCTION (144, cdr, "cdr", 1)
-{
- ARGS1 (x);
- VM_VALIDATE_CONS (x, "cdr");
- RETURN (SCM_CDR (x));
-}
-
-VM_DEFINE_INSTRUCTION (145, set_car, "set-car!", 0, 2, 0)
-{
- SCM x, y;
- POP2 (y, x);
- VM_VALIDATE_CONS (x, "set-car!");
- SCM_SETCAR (x, y);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (146, set_cdr, "set-cdr!", 0, 2, 0)
-{
- SCM x, y;
- POP2 (y, x);
- VM_VALIDATE_CONS (x, "set-cdr!");
- SCM_SETCDR (x, y);
- NEXT;
-}
-
-
-/*
- * Numeric relational tests
- */
-
-#define REL(crel,srel) \
- { \
- ARGS2 (x, y); \
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x)) \
- crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
- SYNC_REGISTER (); \
- RETURN (srel (x, y)); \
- }
-
-VM_DEFINE_FUNCTION (147, ee, "ee?", 2)
-{
- REL (==, scm_num_eq_p);
-}
-
-VM_DEFINE_FUNCTION (148, lt, "lt?", 2)
-{
- REL (<, scm_less_p);
-}
-
-VM_DEFINE_FUNCTION (149, le, "le?", 2)
-{
- REL (<=, scm_leq_p);
-}
-
-VM_DEFINE_FUNCTION (150, gt, "gt?", 2)
-{
- REL (>, scm_gr_p);
-}
-
-VM_DEFINE_FUNCTION (151, ge, "ge?", 2)
-{
- REL (>=, scm_geq_p);
-}
-
-#undef REL
-
-
-/*
- * Numeric functions
- */
-
-/* The maximum/minimum tagged integers. */
-#define INUM_MAX \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
-#define INUM_MIN \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
-#define INUM_STEP \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
- - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
-
-#define FUNC2(CFUNC,SFUNC) \
-{ \
- ARGS2 (x, y); \
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- { \
- scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
- if (SCM_FIXABLE (n)) \
- RETURN (SCM_I_MAKINUM (n)); \
- } \
- SYNC_REGISTER (); \
- RETURN (SFUNC (x, y)); \
-}
-
-/* Assembly tagged integer arithmetic routines. This code uses the
- `asm goto' feature introduced in GCC 4.5. */
-
-#if SCM_GNUC_PREREQ (4, 5) && (defined __x86_64__ || defined __i386__)
-
-# undef _CX
-# ifdef __x86_64__
-# define _CX "rcx"
-# else
-# define _CX "ecx"
-# endif
-
-/* The macros below check the CPU's overflow flag to improve fixnum
- arithmetic. The _CX register (%rcx or %ecx) is explicitly
- clobbered because `asm goto' can't have outputs, in which case the
- `r' constraint could be used to let the register allocator choose a
- register.
-
- TODO: Use `cold' label attribute in GCC 4.6.
- http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html */
-
-# define ASM_ADD(x, y) \
- { \
- asm volatile goto ("mov %1, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_add]; " \
- "test %[tag], %0; je %l[slow_add]; " \
- "sub %[tag], %%"_CX"; " \
- "add %0, %%"_CX"; jo %l[slow_add]; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_add); \
- NEXT; \
- } \
- slow_add: \
- do { } while (0)
-
-# define ASM_SUB(x, y) \
- { \
- asm volatile goto ("mov %0, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_sub]; " \
- "test %[tag], %1; je %l[slow_sub]; " \
- "sub %1, %%"_CX"; jo %l[slow_sub]; " \
- "add %[tag], %%"_CX"; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_sub); \
- NEXT; \
- } \
- slow_sub: \
- do { } while (0)
-
-# define ASM_MUL(x, y) \
- { \
- scm_t_signed_bits xx = SCM_I_INUM (x); \
- asm volatile goto ("mov %1, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_mul]; " \
- "sub %[tag], %%"_CX"; " \
- "test %[tag], %0; je %l[slow_mul]; " \
- "imul %2, %%"_CX"; jo %l[slow_mul]; " \
- "add %[tag], %%"_CX"; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), "r" (xx), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_mul); \
- NEXT; \
- } \
- slow_mul: \
- do { } while (0)
-
-#endif
-
-#if SCM_GNUC_PREREQ (4, 5) && defined __arm__
-
-# define ASM_ADD(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- asm volatile goto ("adds r0, %0, %1; bvs %l[slow_add]; " \
- "str r0, [%[vsp]]\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y - scm_tc2_int), \
- [vsp] "r" (sp) \
- : "r0", "memory", "cc" \
- : slow_add); \
- NEXT; \
- } \
- slow_add: \
- do { } while (0)
-
-# define ASM_SUB(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- asm volatile goto ("subs r0, %0, %1; bvs %l[slow_sub]; " \
- "str r0, [%[vsp]]\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y - scm_tc2_int), \
- [vsp] "r" (sp) \
- : "r0", "memory", "cc" \
- : slow_sub); \
- NEXT; \
- } \
- slow_sub: \
- do { } while (0)
-
-# if defined (__ARM_ARCH_3M__) || defined (__ARM_ARCH_4__) \
- || defined (__ARM_ARCH_4T__) || defined (__ARM_ARCH_5__) \
- || defined (__ARM_ARCH_5T__) || defined (__ARM_ARCH_5E__) \
- || defined (__ARM_ARCH_5TE__) || defined (__ARM_ARCH_5TEJ__) \
- || defined (__ARM_ARCH_6__) || defined (__ARM_ARCH_6J__) \
- || defined (__ARM_ARCH_6K__) || defined (__ARM_ARCH_6Z__) \
- || defined (__ARM_ARCH_6ZK__) || defined (__ARM_ARCH_6T2__) \
- || defined (__ARM_ARCH_6M__) || defined (__ARM_ARCH_7__) \
- || defined (__ARM_ARCH_7A__) || defined (__ARM_ARCH_7R__) \
- || defined (__ARM_ARCH_7M__) || defined (__ARM_ARCH_7EM__) \
- || defined (__ARM_ARCH_8A__)
-
-/* The ARM architectures listed above support the SMULL instruction */
-
-# define ASM_MUL(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- scm_t_signed_bits rlo, rhi; \
- asm ("smull %0, %1, %2, %3\n" \
- : "=r" (rlo), "=r" (rhi) \
- : "r" (SCM_UNPACK (x) - scm_tc2_int), \
- "r" (SCM_I_INUM (y))); \
- if (SCM_LIKELY (SCM_SRS (rlo, 31) == rhi)) \
- RETURN (SCM_PACK (rlo + scm_tc2_int)); \
- } \
- do { } while (0)
-
-# endif
-
-#endif
-
-VM_DEFINE_FUNCTION (152, add, "add", 2)
-{
-#ifndef ASM_ADD
- FUNC2 (+, scm_sum);
-#else
- ARGS2 (x, y);
- ASM_ADD (x, y);
- SYNC_REGISTER ();
- RETURN (scm_sum (x, y));
-#endif
-}
-
-VM_DEFINE_FUNCTION (153, add1, "add1", 1)
-{
- ARGS1 (x);
-
- /* Check for overflow. We must avoid overflow in the signed
- addition below, even if X is not an inum. */
- if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
- {
- SCM result;
-
- /* Add 1 to the integer without untagging. */
- result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
-
- if (SCM_LIKELY (SCM_I_INUMP (result)))
- RETURN (result);
- }
-
- SYNC_REGISTER ();
- RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (154, sub, "sub", 2)
-{
-#ifndef ASM_SUB
- FUNC2 (-, scm_difference);
-#else
- ARGS2 (x, y);
- ASM_SUB (x, y);
- SYNC_REGISTER ();
- RETURN (scm_difference (x, y));
-#endif
-}
-
-VM_DEFINE_FUNCTION (155, sub1, "sub1", 1)
-{
- ARGS1 (x);
-
- /* Check for overflow. We must avoid overflow in the signed
- subtraction below, even if X is not an inum. */
- if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
- {
- SCM result;
-
- /* Substract 1 from the integer without untagging. */
- result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
-
- if (SCM_LIKELY (SCM_I_INUMP (result)))
- RETURN (result);
- }
-
- SYNC_REGISTER ();
- RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (156, mul, "mul", 2)
-{
- ARGS2 (x, y);
-#ifdef ASM_MUL
- ASM_MUL (x, y);
-#endif
- SYNC_REGISTER ();
- RETURN (scm_product (x, y));
-}
-
-#undef ASM_ADD
-#undef ASM_SUB
-#undef ASM_MUL
-#undef FUNC2
-#undef INUM_MAX
-#undef INUM_MIN
-#undef INUM_STEP
-
-VM_DEFINE_FUNCTION (157, div, "div", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_divide (x, y));
-}
-
-VM_DEFINE_FUNCTION (158, quo, "quo", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_quotient (x, y));
-}
-
-VM_DEFINE_FUNCTION (159, rem, "rem", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_remainder (x, y));
-}
-
-VM_DEFINE_FUNCTION (160, mod, "mod", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_modulo (x, y));
-}
-
-VM_DEFINE_FUNCTION (161, ash, "ash", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- {
- if (SCM_I_INUM (y) < 0)
- /* Right shift, will be a fixnum. */
- RETURN (SCM_I_MAKINUM
- (SCM_SRS (SCM_I_INUM (x),
- (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
- ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
- else
- /* Left shift. See comments in scm_ash. */
- {
- scm_t_signed_bits nn, bits_to_shift;
-
- nn = SCM_I_INUM (x);
- bits_to_shift = SCM_I_INUM (y);
-
- if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((scm_t_bits)
- (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
- <= 1))
- RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
- /* fall through */
- }
- /* fall through */
- }
- SYNC_REGISTER ();
- RETURN (scm_ash (x, y));
-}
-
-VM_DEFINE_FUNCTION (162, logand, "logand", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- /* Compute bitwise AND without untagging */
- RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
- SYNC_REGISTER ();
- RETURN (scm_logand (x, y));
-}
-
-VM_DEFINE_FUNCTION (163, logior, "logior", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- /* Compute bitwise OR without untagging */
- RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
- SYNC_REGISTER ();
- RETURN (scm_logior (x, y));
-}
-
-VM_DEFINE_FUNCTION (164, logxor, "logxor", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
- SYNC_REGISTER ();
- RETURN (scm_logxor (x, y));
-}
-
-
-/*
- * Strings
- */
-
-VM_DEFINE_FUNCTION (165, string_length, "string-length", 1)
-{
- ARGS1 (str);
- if (SCM_LIKELY (scm_is_string (str)))
- RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
- else
- {
- SYNC_REGISTER ();
- RETURN (scm_string_length (str));
- }
-}
-
-VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2)
-{
- scm_t_signed_bits i = 0;
- ARGS2 (str, idx);
- if (SCM_LIKELY (scm_is_string (str)
- && SCM_I_INUMP (idx)
- && ((i = SCM_I_INUM (idx)) >= 0)
- && i < scm_i_string_length (str)))
- RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
- else
- {
- SYNC_REGISTER ();
- RETURN (scm_string_ref (str, idx));
- }
-}
-
-/* No string-set! instruction, as there is no good fast path there. */
-
-
-/*
- * Vectors and arrays
- */
-
-VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1)
-{
- ARGS1 (vect);
- if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
- RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
- else
- {
- SYNC_REGISTER ();
- RETURN (scm_vector_length (vect));
- }
-}
-
-VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2)
-{
- scm_t_signed_bits i = 0;
- ARGS2 (vect, idx);
- if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
- && SCM_I_INUMP (idx)
- && ((i = SCM_I_INUM (idx)) >= 0)
- && i < SCM_I_VECTOR_LENGTH (vect)))
- RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
- else
- {
- SYNC_REGISTER ();
- RETURN (scm_vector_ref (vect, idx));
- }
-}
-
-VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0)
-{
- scm_t_signed_bits i = 0;
- SCM vect, idx, val;
- POP3 (val, idx, vect);
- if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
- && SCM_I_INUMP (idx)
- && ((i = SCM_I_INUM (idx)) >= 0)
- && i < SCM_I_VECTOR_LENGTH (vect)))
- SCM_I_VECTOR_WELTS (vect)[i] = val;
- else
- {
- SYNC_REGISTER ();
- scm_vector_set_x (vect, idx, val);
- }
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1)
-{
- scm_t_uint32 len;
- SCM shape, ret;
-
- len = FETCH ();
- len = (len << 8) + FETCH ();
- len = (len << 8) + FETCH ();
- POP (shape);
- SYNC_REGISTER ();
- PRE_CHECK_UNDERFLOW (len);
- ret = scm_from_contiguous_array (shape, sp - len + 1, len);
- DROPN (len);
- PUSH (ret);
- NEXT;
-}
-
-
-/*
- * Structs
- */
-#define VM_VALIDATE_STRUCT(obj, proc) \
- VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_struct (proc, obj))
-
-VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1)
-{
- ARGS1 (obj);
- RETURN (scm_from_bool (SCM_STRUCTP (obj)));
-}
-
-VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1)
-{
- ARGS1 (obj);
- VM_VALIDATE_STRUCT (obj, "struct_vtable");
- RETURN (SCM_STRUCT_VTABLE (obj));
-}
-
-VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- scm_t_bits n = ((h << 8U) + l);
- SCM vtable = sp[-(n - 1)];
- const SCM *inits = sp - n + 2;
- SCM ret;
-
- SYNC_REGISTER ();
-
- if (SCM_LIKELY (SCM_STRUCTP (vtable)
- && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
- == n)
- && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
- {
- /* Verily, we are making a simple struct with the right number of
- initializers, and no finalizer. */
- ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
- n + 1);
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
- memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
- }
- else
- ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
-
- DROPN (n);
- PUSH (ret);
-
- NEXT;
-}
-
-VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2)
-{
- ARGS2 (obj, pos);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- /* True, an inum is a signed value, but cast to unsigned it will
- certainly be more than the length, so we will fall through if
- index is negative. */
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
-
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- RETURN (SCM_PACK (data[index]));
- }
- }
-
- SYNC_REGISTER ();
- RETURN (scm_struct_ref (obj, pos));
-}
-
-VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3)
-{
- ARGS3 (obj, pos, val);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE_RW)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- /* See above regarding index being >= 0. */
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- data[index] = SCM_UNPACK (val);
- RETURN (val);
- }
- }
-
- SYNC_REGISTER ();
- RETURN (scm_struct_set_x (obj, pos, val));
-}
-
-
-/*
- * GOOPS support
- */
-VM_DEFINE_FUNCTION (176, class_of, "class-of", 1)
-{
- ARGS1 (obj);
- if (SCM_INSTANCEP (obj))
- RETURN (SCM_CLASS_OF (obj));
- SYNC_REGISTER ();
- RETURN (scm_class_of (obj));
-}
-
-/* FIXME: No checking whatsoever. */
-VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2)
-{
- size_t slot;
- ARGS2 (instance, idx);
- slot = SCM_I_INUM (idx);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
-}
-
-/* FIXME: No checking whatsoever. */
-VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0)
-{
- SCM instance, idx, val;
- size_t slot;
- POP3 (val, idx, instance);
- slot = SCM_I_INUM (idx);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
- NEXT;
-}
-
-
-/*
- * Bytevectors
- */
-#define VM_VALIDATE_BYTEVECTOR(x, proc) \
- VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
-
-#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
-{ \
- SCM endianness; \
- POP (endianness); \
- if (scm_is_eq (endianness, scm_i_native_endianness)) \
- goto VM_LABEL (bv_##stem##_native_ref); \
- { \
- ARGS2 (bv, idx); \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
- } \
-}
-
-/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
-#define ALIGNED_P(ptr, type) \
- ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
-
-VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3)
-BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3)
-BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3)
-BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3)
-BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3)
-BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3)
-BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3)
-BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3)
-BV_REF_WITH_ENDIANNESS (f64, ieee_double)
-
-#undef BV_REF_WITH_ENDIANNESS
-
-#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const scm_t_ ## type *int_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- RETURN (SCM_I_MAKINUM (*int_ptr)); \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
- } \
-}
-
-#define BV_INT_REF(stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const scm_t_ ## type *int_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- { \
- scm_t_ ## type x = *int_ptr; \
- if (SCM_FIXABLE (x)) \
- RETURN (SCM_I_MAKINUM (x)); \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_from_ ## type (x)); \
- } \
- } \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
- } \
-}
-
-#define BV_FLOAT_REF(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const type *float_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- SYNC_REGISTER (); \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (float_ptr, type)))) \
- RETURN (scm_from_double (*float_ptr)); \
- else \
- RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
-}
-
-VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2)
-BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2)
-BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2)
-BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2)
-BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2)
-#if SIZEOF_VOID_P > 4
-BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
-#else
-BV_INT_REF (u32, uint32, 4)
-#endif
-VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2)
-#if SIZEOF_VOID_P > 4
-BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
-#else
-BV_INT_REF (s32, int32, 4)
-#endif
-VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2)
-BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2)
-BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2)
-BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2)
-BV_FLOAT_REF (f64, ieee_double, double, 8)
-
-#undef BV_FIXABLE_INT_REF
-#undef BV_INT_REF
-#undef BV_FLOAT_REF
-
-
-
-#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
-{ \
- SCM endianness; \
- POP (endianness); \
- if (scm_is_eq (endianness, scm_i_native_endianness)) \
- goto VM_LABEL (bv_##stem##_native_set); \
- { \
- SCM bv, idx, val; POP3 (val, idx, bv); \
- SYNC_REGISTER (); \
- scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
- NEXT; \
- } \
-}
-
-VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (f64, ieee_double)
-
-#undef BV_SET_WITH_ENDIANNESS
-
-#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
-{ \
- scm_t_signed_bits i, j = 0; \
- SCM bv, idx, val; \
- scm_t_ ## type *int_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
- && (SCM_I_INUMP (val)) \
- && ((j = SCM_I_INUM (val)) >= min) \
- && (j <= max))) \
- *int_ptr = (scm_t_ ## type) j; \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-#define BV_INT_SET(stem, type, size) \
-{ \
- scm_t_signed_bits i = 0; \
- SCM bv, idx, val; \
- scm_t_ ## type *int_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- *int_ptr = scm_to_ ## type (val); \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-#define BV_FLOAT_SET(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i = 0; \
- SCM bv, idx, val; \
- type *float_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (float_ptr, type)))) \
- *float_ptr = scm_to_double (val); \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
-#if SIZEOF_VOID_P > 4
-BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
-#else
-BV_INT_SET (u32, uint32, 4)
-#endif
-VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
-#if SIZEOF_VOID_P > 4
-BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
-#else
-BV_INT_SET (s32, int32, 4)
-#endif
-VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
-BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
-BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
-BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
-BV_FLOAT_SET (f64, ieee_double, double, 8)
-
-#undef BV_FIXABLE_INT_SET
-#undef BV_INT_SET
-#undef BV_FLOAT_SET
-
-#undef ALIGNED_P
-#undef VM_VALIDATE_BYTEVECTOR
-
-#undef VM_VALIDATE_STRUCT
-#undef VM_VALIDATE_CONS
-
-#undef ARGS1
-#undef ARGS2
-#undef ARGS3
-#undef RETURN
-
-/*
-(defun renumber-ops ()
- "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
- (interactive "")
- (save-excursion
- (let ((counter 127)) (goto-char (point-min))
- (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
- (replace-match
- (number-to-string (setq counter (1+ counter)))
- t t nil 1)))))
-*/
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
deleted file mode 100644
index e023d562b..000000000
--- a/libguile/vm-i-system.c
+++ /dev/null
@@ -1,1656 +0,0 @@
-/* Copyright (C) 2001,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
- * 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
- */
-
-
-/* This file is included in vm_engine.c */
-
-
-/*
- * Basic operations
- */
-
-VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
-{
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
-{
- SCM ret;
-
- nvalues = SCM_I_INUM (*sp--);
- NULLSTACK (1);
-
- if (nvalues == 1)
- POP (ret);
- else
- {
- SYNC_REGISTER ();
- sp -= nvalues;
- CHECK_UNDERFLOW ();
- ret = scm_c_values (sp + 1, nvalues);
- NULLSTACK (nvalues);
- }
-
- {
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
-#endif
-
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- /* Setting the ip here doesn't actually affect control flow, as the calling
- code will restore its own registers, but it does help when walking the
- stack */
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (old_sp - sp);
- }
-
- SYNC_ALL ();
- return ret;
-}
-
-VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
-{
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1)
-{
- SCM x = *sp;
- PUSH (x);
- NEXT;
-}
-
-
-/*
- * Object creation
- */
-
-VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
-{
- PUSH (SCM_UNSPECIFIED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1)
-{
- PUSH (SCM_BOOL_T);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1)
-{
- PUSH (SCM_BOOL_F);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1)
-{
- PUSH (SCM_ELISP_NIL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
-{
- PUSH (SCM_EOL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
-{
- PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
-{
- PUSH (SCM_INUM0);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
-{
- PUSH (SCM_I_MAKINUM (1));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
-{
- int h = FETCH ();
- int l = FETCH ();
- PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_int64 ((scm_t_int64) v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_uint64 (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
-{
- scm_t_uint8 v = 0;
- v = FETCH ();
-
- PUSH (SCM_MAKE_CHAR (v));
- /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
- contents of SCM_MAKE_CHAR may be evaluated more than once,
- resulting in a double fetch. */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
-{
- scm_t_wchar v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (SCM_MAKE_CHAR (v));
- NEXT;
-}
-
-
-
-VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- POP_LIST (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- SCM vect;
-
- SYNC_REGISTER ();
- sp++; sp -= len;
- CHECK_UNDERFLOW ();
- vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
- memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
- NULLSTACK (len);
- *sp = vect;
-
- NEXT;
-}
-
-
-/*
- * Variable access
- */
-
-#define OBJECT_REF(i) objects[i]
-#define OBJECT_SET(i,o) objects[i] = o
-
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
-
-/* For the variable operations, we _must_ obviously avoid function calls to
- `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
- nothing more than the corresponding macros. */
-#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
-#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
-#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-
-#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
-
-/* ref */
-
-VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
-{
- register unsigned objnum = FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
-{
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
-{
- PUSH (LOCAL_REF (FETCH ()));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (LOCAL_REF (i));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
-{
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1)
-{
- SCM x = *sp;
-
- /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
- unlike in top-variable-ref, it really isn't an internal assertion
- that can be optimized out -- the variable could be coming directly
- from the user. */
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-ref", x));
-
- if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
- {
- SCM var_name;
-
- SYNC_ALL ();
- /* Attempt to provide the variable name in the error message. */
- var_name = scm_module_reverse_lookup (scm_current_module (), x);
- vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
- }
- else
- {
- SCM o = VARIABLE_REF (x);
- *sp = o;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1)
-{
- SCM x = *sp;
-
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-bound?", x));
-
- *sp = scm_from_bool (VARIABLE_BOUNDP (x));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
-{
- unsigned objnum = FETCH ();
- SCM what, resolved;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
-{
- SCM what, resolved;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved),
- vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-/* set */
-
-VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
-{
- SCM x;
- POP (x);
- LOCAL_SET (FETCH (), x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- POP (x);
- LOCAL_SET (i, x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
-{
- VM_ASSERT (SCM_VARIABLEP (sp[0]),
- vm_error_not_a_variable ("variable-set!", sp[0]));
- VARIABLE_SET (sp[0], sp[-1]);
- DROPN (2);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
-{
- unsigned objnum = FETCH ();
- SCM what;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
-{
- SCM what;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-
-/*
- * branch and jump
- */
-
-/* offset must be at least 24 bits wide, and signed */
-#define FETCH_OFFSET(offset) \
-{ \
- offset = FETCH () << 16; \
- offset += FETCH () << 8; \
- offset += FETCH (); \
- offset -= (offset & (1<<23)) << 1; \
-}
-
-#define BR(p) \
-{ \
- scm_t_int32 offset; \
- FETCH_OFFSET (offset); \
- if (p) \
- ip += offset; \
- if (offset < 0) \
- VM_HANDLE_INTERRUPTS; \
- NEXT; \
-}
-
-VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
-{
- scm_t_int32 offset;
- FETCH_OFFSET (offset);
- ip += offset;
- if (offset < 0)
- VM_HANDLE_INTERRUPTS;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_true (x));
-}
-
-VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_false (x));
-}
-
-VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (!scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_null (x));
-}
-
-VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (!scm_is_null (x));
-}
-
-VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_lisp_false (x));
-}
-
-VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (!scm_is_lisp_false (x));
-}
-
-#undef BR
-
-
-/*
- * Subprogram call
- */
-
-VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) != n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) < n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
-{
- scm_t_ptrdiff n;
- scm_t_int32 offset;
-
- n = FETCH () << 8;
- n += FETCH ();
- FETCH_OFFSET (offset);
- if (sp - (fp - 1) > n)
- ip += offset;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) == n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) >= n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- while (sp - (fp - 1) < n)
- PUSH (SCM_UNDEFINED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
-{
- SCM *walk;
- scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
- nreq = FETCH () << 8;
- nreq += FETCH ();
- nreq_and_opt = FETCH () << 8;
- nreq_and_opt += FETCH ();
- ntotal = FETCH () << 8;
- ntotal += FETCH ();
-
- /* look in optionals for first keyword or last positional */
- /* starting after the last required positional arg */
- walk = fp + nreq;
- while (/* while we have args */
- walk <= sp
- /* and we still have positionals to fill */
- && walk - fp < nreq_and_opt
- /* and we haven't reached a keyword yet */
- && !scm_is_keyword (*walk))
- /* bind this optional arg (by leaving it in place) */
- walk++;
- /* now shuffle up, from walk to ntotal */
- {
- scm_t_ptrdiff nshuf = sp - walk + 1, i;
- sp = (fp - 1) + ntotal + nshuf;
- CHECK_OVERFLOW ();
- for (i = 0; i < nshuf; i++)
- sp[-i] = walk[nshuf-i-1];
- }
- /* and fill optionals & keyword args with SCM_UNDEFINED */
- while (walk <= (fp - 1) + ntotal)
- *walk++ = SCM_UNDEFINED;
-
- NEXT;
-}
-
-/* See also bind-optionals/shuffle-or-br below. */
-
-/* Flags that determine whether other keywords are allowed, and whether a
- rest argument is expected. These values must match those used by the
- glil->assembly compiler. */
-#define F_ALLOW_OTHER_KEYS 1
-#define F_REST 2
-
-VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0)
-{
- scm_t_uint16 idx;
- scm_t_ptrdiff nkw;
- int kw_and_rest_flags;
- SCM kw;
- idx = FETCH () << 8;
- idx += FETCH ();
- /* XXX: We don't actually use NKW. */
- nkw = FETCH () << 8;
- nkw += FETCH ();
- kw_and_rest_flags = FETCH ();
-
- VM_ASSERT ((kw_and_rest_flags & F_REST)
- || ((sp - (fp - 1) - nkw) % 2) == 0,
- vm_error_kwargs_length_not_even (program))
-
- CHECK_OBJECT (idx);
- kw = OBJECT_REF (idx);
-
- /* Switch NKW to be a negative index below SP. */
- for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
- {
- SCM walk;
-
- if (scm_is_keyword (sp[nkw]))
- {
- for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
- {
- if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
- {
- SCM si = SCM_CDAR (walk);
- LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
- sp[nkw + 1]);
- break;
- }
- }
- VM_ASSERT (scm_is_pair (walk)
- || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
- vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
- nkw++;
- }
- else
- VM_ASSERT (kw_and_rest_flags & F_REST,
- vm_error_kwargs_invalid_keyword (program, sp[nkw]));
- }
-
- NEXT;
-}
-
-#undef F_ALLOW_OTHER_KEYS
-#undef F_REST
-
-
-VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1)
-{
- scm_t_ptrdiff n;
- SCM rest = SCM_EOL;
- n = FETCH () << 8;
- n += FETCH ();
- SYNC_BEFORE_GC ();
- while (sp - (fp - 1) > n)
- /* No need to check for underflow. */
- rest = scm_cons (*sp--, rest);
- PUSH (rest);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1)
-{
- scm_t_ptrdiff n;
- scm_t_uint32 i;
- SCM rest = SCM_EOL;
- n = FETCH () << 8;
- n += FETCH ();
- i = FETCH () << 8;
- i += FETCH ();
- SYNC_BEFORE_GC ();
- while (sp - (fp - 1) > n)
- /* No need to check for underflow. */
- rest = scm_cons (*sp--, rest);
- LOCAL_SET (i, rest);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1)
-{
- SCM *old_sp;
- scm_t_int32 n;
- n = FETCH () << 8;
- n += FETCH ();
- old_sp = sp;
- sp = (fp - 1) + n;
-
- if (old_sp < sp)
- {
- CHECK_OVERFLOW ();
- while (old_sp < sp)
- *++old_sp = SCM_UNDEFINED;
- }
- else
- NULLSTACK (old_sp - sp);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3)
-{
- /* NB: if you change this, see frames.c:vm-frame-num-locals */
- /* and frames.h, vm-engine.c, etc of course */
-
- /* We don't initialize the dynamic link here because we don't actually
- know that this frame will point to the current fp: it could be
- placed elsewhere on the stack if captured in a partial
- continuation, and invoked from some other context. */
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM *old_fp = fp;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- }
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_tail_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- int i;
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
- CHECK_STACK_LEAK ();
-#endif
-
- /* shuffle down the program and the arguments */
- for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
- SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
-
- sp = fp + i - 1;
-
- NULLSTACK (old_sp - sp);
- }
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1)
-{
- SCM pointer, ret;
- SCM (*subr)();
-
- nargs = FETCH ();
- POP (pointer);
-
- subr = SCM_POINTER_VALUE (pointer);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- switch (nargs)
- {
- case 0:
- ret = subr ();
- break;
- case 1:
- ret = subr (sp[0]);
- break;
- case 2:
- ret = subr (sp[-1], sp[0]);
- break;
- case 3:
- ret = subr (sp[-2], sp[-1], sp[0]);
- break;
- case 4:
- ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 5:
- ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 6:
- ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 7:
- ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 8:
- ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 9:
- ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 10:
- ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- default:
- abort ();
- }
-
- 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;
- }
-}
-
-/* Instruction 58 used to be smob-call. */
-
-VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1)
-{
- SCM foreign, ret;
- nargs = FETCH ();
- POP (foreign);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- ret = scm_i_foreign_call (foreign, sp - nargs + 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;
- }
-}
-
-VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0)
-{
- SCM contregs;
- POP (contregs);
-
- SYNC_ALL ();
- scm_i_check_continuation (contregs);
- vm_return_to_continuation (scm_i_contregs_vm (contregs),
- scm_i_contregs_vm_cont (contregs),
- sp - (fp - 1), fp);
- scm_i_reinstate_continuation (contregs);
-
- /* no NEXT */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0)
-{
- SCM vmcont;
- POP (vmcont);
- SYNC_REGISTER ();
- VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
- vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp,
- &current_thread->dynstack,
- &registers);
-
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (62, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (63, call_nargs, "call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (64, mv_call, "mv-call", 4, -1, 1)
-{
- scm_t_int32 offset;
- scm_t_uint8 *mvra;
- SCM *old_fp = fp;
-
- nargs = FETCH ();
- FETCH_OFFSET (offset);
- mvra = ip + offset;
-
- VM_HANDLE_INTERRUPTS;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (65, apply, "apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (66, tail_apply, "tail-apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (67, call_cc, "call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- scm_t_dynstack *dynstack;
- POP (proc);
- SYNC_ALL ();
- dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
- vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL,
- dynstack, 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_call;
- }
- else
- {
- /* Otherwise, the vm continuation was reinstated, and
- vm_return_to_continuation pushed on one value. We know only one
- value was returned because we are in value context -- the
- previous block jumped to vm_call, not vm_mv_call, after all.
-
- So, pull our regs back down from the vp, and march on to the
- next instruction. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (68, tail_call_cc, "tail-call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- scm_t_dynstack *dynstack;
- POP (proc);
- SYNC_ALL ();
- /* In contrast to call/cc, tail-call/cc captures the continuation without the
- stack frame. */
- dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
- vm_cont = scm_i_vm_capture_stack (vp->stack_base,
- SCM_FRAME_DYNAMIC_LINK (fp),
- SCM_FRAME_LOWER_ADDRESS (fp) - 1,
- SCM_FRAME_RETURN_ADDRESS (fp),
- SCM_FRAME_MV_RETURN_ADDRESS (fp),
- dynstack,
- 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_tail_call;
- }
- else
- {
- /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
- does a return from the frame, either to the RA or
- MVRA. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- /* Unfortunately we don't know whether we are at the RA, and thus
- have one value without an nvalues marker, or we are at the
- MVRA and thus have multiple values and the nvalues
- marker. Instead of adding heuristics here, we will let hook
- client code do that. */
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (69, return, "return", 0, 1, 1)
-{
- vm_return:
- POP_CONTINUATION_HOOK (sp, 1);
-
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM ret;
-
- POP (ret);
-
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
-#endif
-
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
-#ifdef VM_ENABLE_STACK_NULLING
- NULLSTACK (old_sp - sp);
-#endif
-
- /* Set return value (sp is already pushed) */
- *sp = ret;
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (70, 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. */
- nvalues = FETCH ();
- vm_return_values:
- POP_CONTINUATION_HOOK (sp + 1 - nvalues, nvalues);
-
- VM_HANDLE_INTERRUPTS;
-
- if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
- {
- /* A multiply-valued continuation */
- SCM *vals = sp - nvalues;
- int i;
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Push return values, and the number of values */
- for (i = 0; i < nvalues; i++)
- *++sp = vals[i+1];
- *++sp = SCM_I_MAKINUM (nvalues);
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else if (nvalues >= 1)
- {
- /* Multiple values for a single-valued continuation -- here's where I
- break with guile tradition and try and do something sensible. (Also,
- this block handles the single-valued return to an mv
- continuation.) */
- SCM *vals = sp - nvalues;
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Push first value */
- *++sp = vals[1];
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else
- {
- SYNC_ALL ();
- vm_error_no_values ();
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (71, return_values_star, "return/values*", 1, -1, -1)
-{
- SCM l;
-
- nvalues = FETCH ();
- ASSERT (nvalues >= 1);
-
- nvalues--;
- POP (l);
- while (scm_is_pair (l))
- {
- PUSH (SCM_CAR (l));
- l = SCM_CDR (l);
- nvalues++;
- }
- VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
-
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (72, return_nvalues, "return/nvalues", 0, 1, -1)
-{
- SCM n;
- POP (n);
- nvalues = scm_to_int (n);
- ASSERT (nvalues >= 0);
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (73, truncate_values, "truncate-values", 2, -1, -1)
-{
- SCM x;
- int nbinds, rest;
- POP (x);
- nvalues = scm_to_int (x);
- nbinds = FETCH ();
- rest = FETCH ();
-
- if (rest)
- nbinds--;
-
- VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
-
- if (rest)
- POP_LIST (nvalues - nbinds);
- else
- DROPN (nvalues - nbinds);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (74, box, "box", 1, 1, 0)
-{
- SCM val;
- POP (val);
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
- NEXT;
-}
-
-/* for letrec:
- (let ((a *undef*) (b *undef*) ...)
- (set! a (lambda () (b ...)))
- ...)
- */
-VM_DEFINE_INSTRUCTION (75, empty_box, "empty-box", 1, 0, 0)
-{
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (),
- scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (76, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
-{
- SCM v = LOCAL_REF (FETCH ());
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (77, local_boxed_set, "local-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- v = LOCAL_REF (FETCH ());
- POP (val);
- ASSERT_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (78, free_ref, "free-ref", 1, 0, 1)
-{
- scm_t_uint8 idx = FETCH ();
-
- CHECK_FREE_VARIABLE (idx);
- PUSH (FREE_VARIABLE_REF (idx));
- NEXT;
-}
-
-/* no free-set -- if a var is assigned, it should be in a box */
-
-VM_DEFINE_INSTRUCTION (79, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
-{
- SCM v;
- scm_t_uint8 idx = FETCH ();
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (80, free_boxed_set, "free-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- scm_t_uint8 idx = FETCH ();
- POP (val);
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (81, make_closure, "make-closure", 2, -1, 1)
-{
- size_t n, len;
- SCM closure;
-
- len = FETCH ();
- len <<= 8;
- len += FETCH ();
- SYNC_BEFORE_GC ();
- closure = scm_words (scm_tc7_program | (len<<16), len + 3);
- SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
- SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
- sp[-len] = closure;
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (82, make_variable, "make-variable", 0, 0, 1)
-{
- SYNC_BEFORE_GC ();
- /* fixme underflow */
- PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (83, fix_closure, "fix-closure", 2, -1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- size_t n, len;
- i <<= 8;
- i += FETCH ();
- /* FIXME CHECK_LOCAL (i) */
- x = LOCAL_REF (i);
- /* FIXME ASSERT_PROGRAM (x); */
- len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (84, define, "define", 0, 0, 2)
-{
- SCM sym, val;
- POP2 (sym, val);
- SYNC_REGISTER ();
- scm_define (sym, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (85, make_keyword, "make-keyword", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_symbol_to_keyword (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (86, make_symbol, "make-symbol", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_string_to_symbol (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (87, prompt, "prompt", 4, 2, 0)
-{
- scm_t_int32 offset;
- scm_t_uint8 escape_only_p;
- SCM k;
- scm_t_dynstack_prompt_flags flags;
-
- escape_only_p = FETCH ();
- FETCH_OFFSET (offset);
- POP (k);
-
- SYNC_REGISTER ();
- /* Push the prompt onto the dynamic stack. */
- flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
- flags |= SCM_F_DYNSTACK_PROMPT_PUSH_NARGS;
- scm_dynstack_push_prompt (&current_thread->dynstack, flags, k,
- fp, sp, ip + offset, &registers);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (88, wind, "wind", 0, 2, 0)
-{
- SCM wind, unwind;
- POP2 (unwind, wind);
- SYNC_REGISTER ();
- /* Push wind and unwind procedures onto the dynamic stack. Note that neither
- are actually called; the compiler should emit calls to wind and unwind for
- the normal dynamic-wind control flow. Also note that the compiler
- should have inserted checks that they wind and unwind procs are
- thunks, if it could not prove that to be the case. */
- scm_dynstack_push_dynwind (&current_thread->dynstack, wind, unwind);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (89, abort, "abort", 1, -1, -1)
-{
- ptrdiff_t n = FETCH ();
- SCM tag, *stack_args, tail;
- PRE_CHECK_UNDERFLOW (n + 2);
- SYNC_REGISTER ();
- tail = sp[0];
- stack_args = sp - n;
- tag = sp[-(n + 1)];
- /* Partial continuations are now RTL programs, and therefore not
- resumable. Pass NULL as registers to indicate that fact. */
- vm_abort (vm, tag, n, stack_args, tail, sp - (n + 2), NULL);
- /* vm_abort should not return */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (90, unwind, "unwind", 0, 0, 0)
-{
- /* A normal exit from the dynamic extent of an expression. Pop the top entry
- off of the dynamic stack. */
- scm_dynstack_pop (&current_thread->dynstack);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
-{
- SCM fluid, val;
- POP2 (val, fluid);
- SYNC_REGISTER ();
- scm_dynstack_push_fluid (&current_thread->dynstack, fluid, val,
- current_thread->dynamic_state);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
-{
- /* This function must not allocate. */
- scm_dynstack_unwind_fluid (&current_thread->dynstack,
- current_thread->dynamic_state);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (93, fluid_ref, "fluid-ref", 0, 1, 1)
-{
- size_t num;
- SCM fluids;
-
- CHECK_UNDERFLOW ();
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
- || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- *sp = scm_fluid_ref (*sp);
- }
- else
- {
- SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
- if (scm_is_eq (val, SCM_UNDEFINED))
- val = SCM_I_FLUID_DEFAULT (*sp);
- VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
- vm_error_unbound_fluid (program, *sp));
- *sp = val;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (94, fluid_set, "fluid-set", 0, 2, 0)
-{
- size_t num;
- SCM val, fluid, fluids;
-
- POP2 (val, fluid);
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
- || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- scm_fluid_set_x (fluid, val);
- }
- else
- SCM_SIMPLE_VECTOR_SET (fluids, num, val);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
-{
- scm_t_ptrdiff n;
- SCM *old_sp;
-
- /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
- n = FETCH ();
-
- VM_ASSERT (sp - (fp - 1) == (n & 0x7),
- vm_error_wrong_num_args (program));
-
- old_sp = sp;
- sp += (n >> 3);
- CHECK_OVERFLOW ();
- while (old_sp < sp)
- *++old_sp = SCM_UNDEFINED;
-
- NEXT;
-}
-
-/* Like bind-optionals/shuffle, but if there are too many positional
- arguments, jumps to the next case-lambda clause. */
-VM_DEFINE_INSTRUCTION (96, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
-{
- SCM *walk;
- scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
- scm_t_int32 offset;
- nreq = FETCH () << 8;
- nreq += FETCH ();
- nreq_and_opt = FETCH () << 8;
- nreq_and_opt += FETCH ();
- ntotal = FETCH () << 8;
- ntotal += FETCH ();
- FETCH_OFFSET (offset);
-
- /* look in optionals for first keyword or last positional */
- /* starting after the last required positional arg */
- walk = fp + nreq;
- while (/* while we have args */
- walk <= sp
- /* and we still have positionals to fill */
- && walk - fp < nreq_and_opt
- /* and we haven't reached a keyword yet */
- && !scm_is_keyword (*walk))
- /* bind this optional arg (by leaving it in place) */
- walk++;
- if (/* If we have filled all the positionals */
- walk - fp == nreq_and_opt
- /* and there are still more arguments */
- && walk <= sp
- /* and the next argument is not a keyword, */
- && !scm_is_keyword (*walk))
- {
- /* Jump to the next case-lambda* clause. */
- ip += offset;
- }
- else
- {
- /* Otherwise, finish as in bind-optionals/shuffle: shuffle up,
- from walk to ntotal */
- scm_t_ptrdiff nshuf = sp - walk + 1, i;
- sp = (fp - 1) + ntotal + nshuf;
- CHECK_OVERFLOW ();
- for (i = 0; i < nshuf; i++)
- sp[-i] = walk[nshuf-i-1];
-
- /* and fill optionals & keyword args with SCM_UNDEFINED */
- while (walk <= (fp - 1) + ntotal)
- *walk++ = SCM_UNDEFINED;
- }
-
- 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)))))
-(renumber-ops)
-*/
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/vm.c b/libguile/vm.c
index f87236e16..5b3263993 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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,10 +870,7 @@ 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);
+ return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
}
/* Scheme interface */
@@ -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)
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index ff1114727..4c2103391 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -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)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 22287f6d4..5a87cd99b 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -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) '()))
diff --git a/module/statprof.scm b/module/statprof.scm
index 36c53a585..bb6751b7b 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -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
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 251cd8966..2ca73648d 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -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)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index e3b3352d5..ed042face 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -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)
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
index 81c6ab5b9..78d9db137 100644
--- a/module/system/vm/instruction.scm
+++ b/module/system/vm/instruction.scm
@@ -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")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index f99df8091..243f43eee 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -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))))
+ (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))))
(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)