[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-377-g1c33be9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-377-g1c33be9 |
|
Date: |
Fri, 08 Nov 2013 18:21:37 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=1c33be992e8120abd20add8021e4d91d226f5b6a
The branch, master has been updated
via 1c33be992e8120abd20add8021e4d91d226f5b6a (commit)
from 84680d238299c3b2c8be42b16a8be0ff6e02ba5c (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 1c33be992e8120abd20add8021e4d91d226f5b6a
Author: Andy Wingo <address@hidden>
Date: Fri Nov 8 18:28:24 2013 +0100
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.
-----------------------------------------------------------------------
Summary of changes:
libguile/Makefile.am | 10 +-
libguile/_scm.h | 7 -
libguile/evalext.c | 4 +-
libguile/frames.c | 30 +-
libguile/gc.c | 2 -
libguile/goops.c | 11 -
libguile/instructions.c | 162 ----
libguile/instructions.h | 17 -
libguile/objcodes.c | 206 -----
libguile/objcodes.h | 49 +-
libguile/print.c | 4 -
libguile/procprop.c | 11 +-
libguile/procs.c | 3 +-
libguile/programs.c | 323 +-------
libguile/programs.h | 22 -
libguile/smob.c | 1 -
libguile/snarf.h | 21 -
libguile/stacks.c | 3 +-
libguile/tags.h | 4 +-
libguile/vm-engine.c | 430 ---------
libguile/vm-i-loader.c | 134 ---
libguile/vm-i-scheme.c | 1126 ------------------------
libguile/vm-i-system.c | 1656 -----------------------------------
libguile/vm.c | 42 +-
module/ice-9/session.scm | 3 +-
module/language/tree-il/analyze.scm | 2 +-
module/statprof.scm | 3 -
module/system/repl/debug.scm | 3 +-
module/system/vm/frame.scm | 6 +-
module/system/vm/instruction.scm | 8 +-
module/system/vm/program.scm | 56 +-
31 files changed, 51 insertions(+), 4308 deletions(-)
delete mode 100644 libguile/vm-i-loader.c
delete mode 100644 libguile/vm-i-scheme.c
delete mode 100644 libguile/vm-i-system.c
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index e3a9e00..b2a9faf 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
address@hidden@_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 1ec93fb..7afb5a1 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 f955cee..897cabe 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 d32f837..ce671b8 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 581bbc5..dfec8d5 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 49840bf..1f56d34 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 43937d7..3dc15c2 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 63bff7a..fc9bce8 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 fa4e28b..358a1e7 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 6ac333f..2d439f7 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 a77f1a8..2091539 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 5bb9e62..488edcc 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 b021824..bf965ee 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 f74e4ed..a2c3fc9 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 0d33957..4b28b6e 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 857773c..e13591f 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 7843ac8..afc4d8f 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 fd19a49..bbdde30 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 9e6943e..1c6503a 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 567bdbc..d657a08 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 c323156..0000000
--- 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 07bb644..0000000
--- 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 e023d56..0000000
--- 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,
- ¤t_thread->dynstack,
- ®isters);
-
- 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 (¤t_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 (¤t_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 (¤t_thread->dynstack, flags, k,
- fp, sp, ip + offset, ®isters);
- 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 (¤t_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 (¤t_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 (¤t_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 (¤t_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 f87236e..5b32639 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 ff11147..4c21033 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 22287f6..5a87cd9 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 36c53a5..bb6751b 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 251cd89..2ca7364 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 e3b3352..ed042fa 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 81c6ab5..78d9db1 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 f99df80..243f43e 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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-377-g1c33be9,
Andy Wingo <=