diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-08 18:28:24 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-08 18:28:24 +0100 |
commit | 1c33be992e8120abd20add8021e4d91d226f5b6a (patch) | |
tree | 71f78961b6a29aa1e342049419f402af555e6f20 | |
parent | 84680d238299c3b2c8be42b16a8be0ff6e02ba5c (diff) | |
download | guile-1c33be992e8120abd20add8021e4d91d226f5b6a.tar.gz |
Remove stack programs, objcode, and the old VM.
* libguile/Makefile.am:
* libguile/vm-i-loader.c:
* libguile/vm-i-scheme.c:
* libguile/vm-i-system.c: Remove the old VM files, and the rules to
build the .i files.
* libguile/vm-engine.c:
* libguile/vm.c: Remove the old VM. Woot!
* libguile/_scm.h (SCM_OBJCODE_COOKIE, SCM_OBJCODE_ENDIANNESS_OFFSET)
(SCM_OBJCODE_WORD_SIZE_OFFSET): Remove.
* libguile/evalext.c (scm_self_evaluating_p): Remove objcode and program
cases.
* libguile/frames.c (scm_frame_num_locals, scm_frame_previous): Remove
program cases.
* libguile/gc.c (scm_i_tag_name): Remove objcode case.
* libguile/goops.c (scm_class_of, create_standard_classes): Remove
objcode and program cases.
* libguile/instructions.h:
* libguile/instructions.c (scm_instruction_list, scm_instruction_p)
(scm_instruction_length, scm_instruction_pops, scm_instruction_pushes)
(scm_instruction_to_opcode, scm_opcode_to_instruction): Remove old VM
code.
* libguile/objcodes.h:
* libguile/objcodes.c: Remove the objcode data type, and handling for
objcode files.
* libguile/print.c: Remove objcode and program printers.
* libguile/procprop.c: Remove program cases.
* libguile/procs.c:
* libguile/programs.h:
* libguile/programs.c: Remove old program code.
* libguile/smob.c: Remove objcodes include.
* libguile/snarf.h: Remove static program defines.
* libguile/stacks.c: Remove program case.
* libguile/tags.h: Remove program and objcode tc7s.
* module/ice-9/session.scm (procedure-arguments)
* module/language/tree-il/analyze.scm (validate-arity)
* module/statprof.scm (get-call-data, procedure=?)
* module/system/vm/frame.scm (frame-bindings)
(frame-call-representation): Remove old program cases.
* module/system/repl/debug.scm (frame->module): Add a FIXME.
* module/system/vm/instruction.scm: Remove old exports.
* module/system/vm/program.scm: Remove old program code.
31 files changed, 51 insertions, 4308 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e3a9e00ce..b2a9faf3a 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -428,11 +428,6 @@ DOT_DOC_FILES = \ EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ -DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i - -.c.i: - $(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@ - vm-operations.h: vm-engine.c @echo '/* This file was generated automatically from $<; do not' > $@ @echo ' edit. See the source file for copyright information. */' >> $@ @@ -476,7 +471,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ private-gc.h private-options.h ports-internal.h # vm instructions -noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c +noinst_HEADERS += vm-engine.c libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES = @LIBLOBJS@ @@ -802,7 +797,6 @@ chknew-E chknew-SIG: \ MOSTLYCLEANFILES = \ scmconfig.h scmconfig.h.tmp -CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi \ - vm-i-*.i +CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi MAINTAINERCLEANFILES = c-tokenize.c diff --git a/libguile/_scm.h b/libguile/_scm.h index 1ec93fbb4..7afb5a11f 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -280,13 +280,6 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); #define SCM_OBJCODE_MACHINE_VERSION_STRING \ SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE "-" SCM_OBJCODE_VERSION_STRING -/* The objcode magic header. */ -#define SCM_OBJCODE_COOKIE \ - "GOOF----" SCM_OBJCODE_MACHINE_VERSION_STRING -#define SCM_OBJCODE_ENDIANNESS_OFFSET 8 -#define SCM_OBJCODE_WORD_SIZE_OFFSET 11 - - #endif /* SCM__SCM_H */ /* diff --git a/libguile/evalext.c b/libguile/evalext.c index f955cee7f..897cabe44 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -81,14 +81,12 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_fluid: case scm_tc7_dynamic_state: case scm_tc7_frame: - case scm_tc7_objcode: case scm_tc7_vm: case scm_tc7_vm_cont: case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: case scm_tc7_rtl_program: - case scm_tc7_program: case scm_tc7_bytevector: case scm_tc7_array: case scm_tc7_bitvector: diff --git a/libguile/frames.c b/libguile/frames.c index d32f8374c..ce671b889 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -120,35 +120,18 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, "") #define FUNC_NAME s_scm_frame_num_locals { - SCM *fp, *sp, *p; + SCM *sp, *p; unsigned int n = 0; SCM_VALIDATE_VM_FRAME (1, frame); - fp = SCM_VM_FRAME_FP (frame); sp = SCM_VM_FRAME_SP (frame); p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - if (SCM_RTL_PROGRAM_P (fp[-1])) - /* The frame size of an RTL program is fixed, except in the case of - passing a wrong number of arguments to the program. So we do - need to use an SP for determining the number of locals. */ - return scm_from_ptrdiff_t (sp + 1 - p); - - sp = SCM_VM_FRAME_SP (frame); - p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame)); - while (p <= sp) - { - if (SCM_UNPACK (p[0]) == 0) - /* skip over not-yet-active frame */ - p += 3; - else - { - p++; - n++; - } - } - return scm_from_uint (n); + /* The frame size of an RTL program is fixed, except in the case of + passing a wrong number of arguments to the program. So we do + need to use an SP for determining the number of locals. */ + return scm_from_ptrdiff_t (sp + 1 - p); } #undef FUNC_NAME @@ -311,8 +294,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, SCM_VM_FRAME_OFFSET (frame)); proc = scm_frame_procedure (frame); - if ((SCM_PROGRAM_P (proc) || SCM_RTL_PROGRAM_P (proc)) - && SCM_PROGRAM_IS_BOOT (proc)) + if (SCM_RTL_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc)) goto again; else return frame; diff --git a/libguile/gc.c b/libguile/gc.c index 581bbc527..dfec8d5a3 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -944,8 +944,6 @@ scm_i_tag_name (scm_t_bits tag) return "dynamic state"; case scm_tc7_frame: return "frame"; - case scm_tc7_objcode: - return "objcode"; case scm_tc7_vm: return "vm"; case scm_tc7_vm_cont: diff --git a/libguile/goops.c b/libguile/goops.c index 49840bf4a..1f56d34c7 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -155,7 +155,6 @@ static SCM class_hashtable; static SCM class_fluid; static SCM class_dynamic_state; static SCM class_frame; -static SCM class_objcode; static SCM class_vm; static SCM class_vm_cont; static SCM class_bytevector; @@ -266,8 +265,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_dynamic_state; case scm_tc7_frame: return class_frame; - case scm_tc7_objcode: - return class_objcode; case scm_tc7_vm: return class_vm; case scm_tc7_vm_cont: @@ -294,13 +291,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc16_fraction: return scm_class_fraction; } - case scm_tc7_program: case scm_tc7_rtl_program: - /* Although SCM_SUBR_GENERIC is specific to stack programs - currently, in practice only stack programs pass - SCM_PROGRAM_IS_PRIMITIVE_GENERIC. In the future this will - change to be the other way around, when subrs become RTL - programs. */ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && SCM_UNPACK (*SCM_SUBR_GENERIC (x))) return scm_class_primitive_generic; @@ -2521,8 +2512,6 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_frame, "<frame>", scm_class_class, scm_class_top, SCM_EOL); - make_stdcls (&class_objcode, "<objcode>", - scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_vm, "<vm>", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_vm_cont, "<vm-continuation>", diff --git a/libguile/instructions.c b/libguile/instructions.c index 43937d76a..3dc15c2ff 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -27,20 +27,6 @@ #include "instructions.h" -struct scm_instruction { - enum scm_opcode opcode; /* opcode */ - const char *name; /* instruction name */ - signed char len; /* Instruction length. This may be -1 for - the loader (see the `VM_LOADER' - macro). */ - signed char npop; /* The number of values popped. This may be - -1 for insns like `call' which can take - any number of arguments. */ - char npush; /* the number of values pushed */ - SCM symname; /* filled in later */ -}; - - SCM_SYMBOL (sym_left_arrow, "<-"); SCM_SYMBOL (sym_bang, "!"); @@ -133,38 +119,6 @@ struct scm_rtl_instruction { static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -static const struct scm_instruction* -fetch_instruction_table () -{ - static struct scm_instruction *table = NULL; - - scm_i_pthread_mutex_lock (&itable_lock); - if (SCM_UNLIKELY (!table)) - { - size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction); - int i; - table = malloc (bytes); - memset (table, 0, bytes); -#define VM_INSTRUCTION_TO_TABLE 1 -#include <libguile/vm-expand.h> -#include <libguile/vm-i-system.i> -#include <libguile/vm-i-scheme.i> -#include <libguile/vm-i-loader.i> -#undef VM_INSTRUCTION_TO_TABLE - for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - { - table[i].opcode = i; - if (table[i].name) - table[i].symname = scm_from_utf8_symbol (table[i].name); - else - table[i].symname = SCM_BOOL_F; - } - } - scm_i_pthread_mutex_unlock (&itable_lock); - - return table; -} - static const struct scm_rtl_instruction* fetch_rtl_instruction_table () { @@ -196,51 +150,9 @@ fetch_rtl_instruction_table () return table; } -static const struct scm_instruction * -scm_lookup_instruction_by_name (SCM name) -{ - static SCM instructions_by_name = SCM_BOOL_F; - const struct scm_instruction *table = fetch_instruction_table (); - SCM op; - - if (SCM_UNLIKELY (scm_is_false (instructions_by_name))) - { - unsigned int i; - - instructions_by_name = - scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS)); - - for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - if (scm_is_true (table[i].symname)) - scm_hashq_set_x (instructions_by_name, table[i].symname, - SCM_I_MAKINUM (i)); - } - - op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED); - if (SCM_I_INUMP (op)) - return &table[SCM_I_INUM (op)]; - - return NULL; -} - /* Scheme interface */ -SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, - (void), - "") -#define FUNC_NAME s_scm_instruction_list -{ - SCM list = SCM_EOL; - int i; - const struct scm_instruction *ip = fetch_instruction_table (); - for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - if (ip[i].name) - list = scm_cons (ip[i].symname, list); - return scm_reverse_x (list, SCM_EOL); -} -#undef FUNC_NAME - SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0, (void), "") @@ -297,80 +209,6 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, - (SCM obj), - "") -#define FUNC_NAME s_scm_instruction_p -{ - return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0, - (SCM inst), - "") -#define FUNC_NAME s_scm_instruction_length -{ - const struct scm_instruction *ip; - SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); - return SCM_I_MAKINUM (ip->len); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0, - (SCM inst), - "") -#define FUNC_NAME s_scm_instruction_pops -{ - const struct scm_instruction *ip; - SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); - return SCM_I_MAKINUM (ip->npop); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0, - (SCM inst), - "") -#define FUNC_NAME s_scm_instruction_pushes -{ - const struct scm_instruction *ip; - SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); - return SCM_I_MAKINUM (ip->npush); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0, - (SCM inst), - "") -#define FUNC_NAME s_scm_instruction_to_opcode -{ - const struct scm_instruction *ip; - SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); - return SCM_I_MAKINUM (ip->opcode); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, - (SCM op), - "") -#define FUNC_NAME s_scm_opcode_to_instruction -{ - scm_t_signed_bits opcode; - SCM ret = SCM_BOOL_F; - - SCM_MAKE_VALIDATE (1, op, I_INUMP); - opcode = SCM_I_INUM (op); - - if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS) - ret = fetch_instruction_table ()[opcode].symname; - - if (scm_is_false (ret)) - scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P"); - - return ret; -} -#undef FUNC_NAME - void scm_bootstrap_instructions (void) { diff --git a/libguile/instructions.h b/libguile/instructions.h index 63bff7ae7..fc9bce8ee 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -78,25 +78,8 @@ enum scm_rtl_opcode #define SCM_VM_NUM_INSTRUCTIONS (1<<8) #define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1) -enum scm_opcode { -#define VM_INSTRUCTION_TO_OPCODE 1 -#include <libguile/vm-expand.h> -#include <libguile/vm-i-system.i> -#include <libguile/vm-i-scheme.i> -#include <libguile/vm-i-loader.i> -#undef VM_INSTRUCTION_TO_OPCODE -}; - SCM_INTERNAL SCM scm_rtl_instruction_list (void); -SCM_API SCM scm_instruction_list (void); -SCM_API SCM scm_instruction_p (SCM obj); -SCM_API SCM scm_instruction_length (SCM inst); -SCM_API SCM scm_instruction_pops (SCM inst); -SCM_API SCM scm_instruction_pushes (SCM inst); -SCM_API SCM scm_instruction_to_opcode (SCM inst); -SCM_API SCM scm_opcode_to_instruction (SCM op); - SCM_INTERNAL void scm_bootstrap_instructions (void); SCM_INTERNAL void scm_init_instructions (void); diff --git a/libguile/objcodes.c b/libguile/objcodes.c index fa4e28b39..358a1e77a 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -42,18 +42,6 @@ #include "programs.h" #include "objcodes.h" -/* Before, we used __BYTE_ORDER, but that is not defined on all - systems. So punt and use automake, PDP endianness be damned. */ -#define SCM_BYTE_ORDER_BE 4321 -#define SCM_BYTE_ORDER_LE 1234 - -/* Byte order of the build machine. */ -#ifdef WORDS_BIGENDIAN -#define SCM_BYTE_ORDER SCM_BYTE_ORDER_BE -#else -#define SCM_BYTE_ORDER SCM_BYTE_ORDER_LE -#endif - /* This file contains the loader for Guile's on-disk format: ELF with some custom tags in the dynamic segment. */ @@ -94,7 +82,6 @@ static void register_elf (char *data, size_t len); enum bytecode_kind { BYTECODE_KIND_NONE, - BYTECODE_KIND_GUILE_2_0, BYTECODE_KIND_GUILE_2_2 }; @@ -103,14 +90,6 @@ pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr) { switch (bytecode_kind) { - case BYTECODE_KIND_GUILE_2_0: - { - SCM objcode; - scm_t_bits tag = SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0); - - objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0); - return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED); - } case BYTECODE_KIND_GUILE_2_2: { return scm_i_make_rtl_program ((scm_t_uint32 *) ptr); @@ -309,11 +288,6 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff; switch (major) { - case 0x0200: - bytecode_kind = BYTECODE_KIND_GUILE_2_0; - if (minor > SCM_OBJCODE_MINOR_VERSION) - return "incompatible bytecode version"; - break; case 0x0202: bytecode_kind = BYTECODE_KIND_GUILE_2_2; if (minor) @@ -332,12 +306,6 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, switch (bytecode_kind) { - case BYTECODE_KIND_GUILE_2_0: - if (init) - return "unexpected DT_INIT"; - if ((scm_t_uintptr) entry % 8) - return "unaligned DT_GUILE_ENTRY"; - break; case BYTECODE_KIND_GUILE_2_2: if ((scm_t_uintptr) init % 4) return "unaligned DT_INIT"; @@ -590,55 +558,6 @@ SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0, #undef FUNC_NAME -/* - * Objcode type - */ - -/* Convert X, which is in byte order BYTE_ORDER, to its native - representation. */ -static inline uint32_t -to_native_order (uint32_t x, int byte_order) -{ - if (byte_order == SCM_BYTE_ORDER) - return x; - else - return bswap_32 (x); -} - -SCM -scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) -#define FUNC_NAME "make-objcode-slice" -{ - const struct scm_objcode *data, *parent_data; - const scm_t_uint8 *parent_base; - - SCM_VALIDATE_OBJCODE (1, parent); - parent_data = SCM_OBJCODE_DATA (parent); - parent_base = SCM_C_OBJCODE_BASE (parent_data); - - if (ptr < parent_base - || ptr >= (parent_base + parent_data->len + parent_data->metalen - - sizeof (struct scm_objcode))) - scm_misc_error - (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)", - scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr), - scm_from_unsigned_integer ((scm_t_bits) parent_base), - scm_from_uint32 (parent_data->len), - scm_from_uint32 (parent_data->metalen))); - - /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to - do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */ - assert ((((scm_t_bits) ptr) & - (alignof_type (struct scm_objcode) - 1UL)) == 0); - - data = (struct scm_objcode*) ptr; - assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen - <= parent_base + parent_data->len + parent_data->metalen); - - return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0), - (scm_t_bits)data, SCM_UNPACK (parent), 0); -} -#undef FUNC_NAME struct mapped_elf_image { @@ -763,128 +682,6 @@ scm_all_mapped_elf_images (void) } -/* - * Scheme interface - */ - -SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, - (SCM obj), - "") -#define FUNC_NAME s_scm_objcode_p -{ - return scm_from_bool (SCM_OBJCODE_P (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, - (SCM objcode), - "") -#define FUNC_NAME s_scm_objcode_meta -{ - SCM_VALIDATE_OBJCODE (1, objcode); - - if (SCM_OBJCODE_META_LEN (objcode) == 0) - return SCM_BOOL_F; - else - return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) - + SCM_OBJCODE_LEN (objcode))); -} -#undef FUNC_NAME - -/* Wrap BYTECODE in objcode, interpreting its lengths according to - BYTE_ORDER. */ -static SCM -bytecode_to_objcode (SCM bytecode, int byte_order) -#define FUNC_NAME "bytecode->objcode" -{ - size_t size, len, metalen; - const scm_t_uint8 *c_bytecode; - struct scm_objcode *data; - - if (!scm_is_bytevector (bytecode)) - scm_wrong_type_arg (FUNC_NAME, 1, bytecode); - - size = SCM_BYTEVECTOR_LENGTH (bytecode); - c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode); - - SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode)); - data = (struct scm_objcode*)c_bytecode; - - len = to_native_order (data->len, byte_order); - metalen = to_native_order (data->metalen, byte_order); - - if (len + metalen != (size - sizeof (*data))) - scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)", - scm_list_2 (scm_from_size_t (size), - scm_from_uint32 (sizeof (*data) + len + metalen))); - - /* foolishly, we assume that as long as bytecode is around, that c_bytecode - will be of the same length; perhaps a bad assumption? */ - return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0), - (scm_t_bits)data, SCM_UNPACK (bytecode), 0); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 1, 0, - (SCM bytecode, SCM endianness), - "") -#define FUNC_NAME s_scm_bytecode_to_objcode -{ - int byte_order; - - if (SCM_UNBNDP (endianness)) - byte_order = SCM_BYTE_ORDER; - else if (scm_is_eq (endianness, scm_endianness_big)) - byte_order = SCM_BYTE_ORDER_BE; - else if (scm_is_eq (endianness, scm_endianness_little)) - byte_order = SCM_BYTE_ORDER_LE; - else - scm_wrong_type_arg (FUNC_NAME, 2, endianness); - - return bytecode_to_objcode (bytecode, byte_order); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 1, 0, - (SCM objcode, SCM endianness), - "") -#define FUNC_NAME s_scm_objcode_to_bytecode -{ - scm_t_uint32 len, meta_len, total_len; - int byte_order; - - SCM_VALIDATE_OBJCODE (1, objcode); - - if (SCM_UNBNDP (endianness)) - byte_order = SCM_BYTE_ORDER; - else if (scm_is_eq (endianness, scm_endianness_big)) - byte_order = SCM_BYTE_ORDER_BE; - else if (scm_is_eq (endianness, scm_endianness_little)) - byte_order = SCM_BYTE_ORDER_LE; - else - scm_wrong_type_arg (FUNC_NAME, 2, endianness); - - len = SCM_OBJCODE_LEN (objcode); - meta_len = SCM_OBJCODE_META_LEN (objcode); - - total_len = sizeof (struct scm_objcode); - total_len += to_native_order (len, byte_order); - total_len += to_native_order (meta_len, byte_order); - - return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode), - total_len, objcode); -} -#undef FUNC_NAME - -void -scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate) -{ - scm_puts_unlocked ("#<objcode ", port); - scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port); - scm_puts_unlocked (">", port); -} - - void scm_bootstrap_objcodes (void) { @@ -904,9 +701,6 @@ scm_init_objcodes (void) (scm_t_subr) scm_find_mapped_elf_image); scm_c_define_gsubr ("all-mapped-elf-images", 0, 0, 0, (scm_t_subr) scm_all_mapped_elf_images); - - scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); - scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); } /* diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 6ac333fa4..2d439f7b4 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -21,56 +21,9 @@ #include <libguile.h> -/* Objcode data should be directly mappable to this C structure. */ -struct scm_objcode -{ - scm_t_uint32 len; /* the maximum index of base[] */ - scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of - base[] for metadata */ - /* In C99, we'd have: - scm_t_uint8 base[]; */ -}; - -/* Return a pointer to the base of objcode OBJ. */ -#define SCM_C_OBJCODE_BASE(obj) \ - ((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode)) - -#define SCM_OBJCODE_TYPE_MMAP (0) -#define SCM_OBJCODE_TYPE_BYTEVECTOR (1) -#define SCM_OBJCODE_TYPE_SLICE (2) -#define SCM_OBJCODE_TYPE_STATIC (3) - -#define SCM_OBJCODE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_objcode)) -#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x)) -#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P) - -#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len) -#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen) -#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x)) -#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x))) - -#define SCM_MAKE_OBJCODE_TAG(type, flags) (scm_tc7_objcode | (type << 8) | (flags << 16)) -#define SCM_OBJCODE_TYPE(x) ((SCM_CELL_WORD_0 (x) >> 8) & 0xff) -#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16) -#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_MMAP) -#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_BYTEVECTOR) -#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_SLICE) -#define SCM_OBJCODE_IS_STATIC(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_STATIC) - -#define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x)) -#define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code)) - SCM_API SCM scm_load_thunk_from_file (SCM filename); SCM_API SCM scm_load_thunk_from_memory (SCM bv); -SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr); -SCM_API SCM scm_objcode_p (SCM obj); -SCM_API SCM scm_objcode_meta (SCM objcode); -SCM_API SCM scm_bytecode_to_objcode (SCM bytecode, SCM endianness); -SCM_API SCM scm_objcode_to_bytecode (SCM objcode, SCM endianness); - -SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port, - scm_print_state *pstate); SCM_INTERNAL void scm_bootstrap_objcodes (void); SCM_INTERNAL void scm_init_objcodes (void); diff --git a/libguile/print.c b/libguile/print.c index a77f1a8b4..2091539a6 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -661,7 +661,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_i_variable_print (exp, port, pstate); break; case scm_tc7_rtl_program: - case scm_tc7_program: scm_i_program_print (exp, port, pstate); break; case scm_tc7_pointer: @@ -685,9 +684,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_frame: scm_i_frame_print (exp, port, pstate); break; - case scm_tc7_objcode: - scm_i_objcode_print (exp, port, pstate); - break; case scm_tc7_vm: scm_i_vm_print (exp, port, pstate); break; diff --git a/libguile/procprop.c b/libguile/procprop.c index 5bb9e6259..488edcc7c 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -61,7 +61,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) return 1; } - while (!SCM_PROGRAM_P (proc) && !SCM_RTL_PROGRAM_P (proc)) + while (!SCM_RTL_PROGRAM_P (proc)) { if (SCM_STRUCTP (proc)) { @@ -146,9 +146,7 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props))) return scm_cdr (user_props); - if (SCM_PROGRAM_P (proc)) - ret = scm_i_program_properties (proc); - else if (SCM_RTL_PROGRAM_P (proc)) + if (SCM_RTL_PROGRAM_P (proc)) ret = scm_i_rtl_program_properties (proc); else ret = SCM_EOL; @@ -262,8 +260,6 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, if (SCM_RTL_PROGRAM_P (proc)) return scm_i_rtl_program_name (proc); - else if (SCM_PROGRAM_P (proc)) - return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name); else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc)); else @@ -301,9 +297,6 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, if (SCM_RTL_PROGRAM_P (proc)) return scm_i_rtl_program_documentation (proc); - else if (SCM_PROGRAM_P (proc)) - return scm_assq_ref (scm_i_program_properties (proc), - scm_sym_documentation); else return SCM_BOOL_F; } diff --git a/libguile/procs.c b/libguile/procs.c index b02182427..bf965ee58 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -47,8 +47,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, "Return @code{#t} if @var{obj} is a procedure.") #define FUNC_NAME s_scm_procedure_p { - return scm_from_bool (SCM_PROGRAM_P (obj) - || SCM_RTL_PROGRAM_P (obj) + return scm_from_bool (SCM_RTL_PROGRAM_P (obj) || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj)) || (SCM_HAS_TYP7 (obj, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (obj))); diff --git a/libguile/programs.c b/libguile/programs.c index f74e4ed5c..a2c3fc90b 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -22,53 +22,14 @@ #include <string.h> #include "_scm.h" -#include "instructions.h" #include "modules.h" #include "programs.h" #include "procprop.h" /* scm_sym_name */ -#include "srcprop.h" /* scm_sym_filename */ #include "vm.h" static SCM write_program = SCM_BOOL_F; -SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, - (SCM objcode, SCM objtable, SCM free_variables), - "") -#define FUNC_NAME s_scm_make_program -{ - SCM_VALIDATE_OBJCODE (1, objcode); - if (SCM_UNLIKELY (SCM_UNBNDP (objtable))) - objtable = SCM_BOOL_F; - else if (scm_is_true (objtable)) - SCM_VALIDATE_VECTOR (2, objtable); - - if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables)) - { - SCM ret = scm_words (scm_tc7_program, 3); - SCM_SET_CELL_OBJECT_1 (ret, objcode); - SCM_SET_CELL_OBJECT_2 (ret, objtable); - return ret; - } - else - { - size_t i, len; - SCM ret; - SCM_VALIDATE_VECTOR (3, free_variables); - len = scm_c_vector_length (free_variables); - if (SCM_UNLIKELY (len >> 16)) - SCM_OUT_OF_RANGE (3, free_variables); - ret = scm_words (scm_tc7_program | (len<<16), 3 + len); - SCM_SET_CELL_OBJECT_1 (ret, objcode); - SCM_SET_CELL_OBJECT_2 (ret, objtable); - for (i = 0; i < len; i++) - SCM_SET_CELL_OBJECT (ret, 3+i, - SCM_SIMPLE_VECTOR_REF (free_variables, i)); - return ret; - } -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2, 0, (SCM bytevector, SCM byte_offset, SCM free_variables), "") @@ -186,20 +147,11 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) } else if (scm_is_false (write_program) || print_error) { - if (SCM_RTL_PROGRAM_P (program)) - { - scm_puts_unlocked ("#<rtl-program ", port); - scm_uintprint (SCM_UNPACK (program), 16, port); - scm_putc_unlocked (' ', port); - scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port); - scm_putc_unlocked ('>', port); - } - else - { - scm_puts_unlocked ("#<program ", port); - scm_uintprint (SCM_UNPACK (program), 16, port); - scm_putc_unlocked ('>', port); - } + scm_puts_unlocked ("#<rtl-program ", port); + scm_uintprint (SCM_UNPACK (program), 16, port); + scm_putc_unlocked (' ', port); + scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port); + scm_putc_unlocked ('>', port); } else { @@ -214,15 +166,6 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) * Scheme interface */ -SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, - (SCM obj), - "") -#define FUNC_NAME s_scm_program_p -{ - return scm_from_bool (SCM_PROGRAM_P (obj)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0, (SCM obj), "") @@ -252,152 +195,6 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_base -{ - const struct scm_objcode *c_objcode; - - SCM_VALIDATE_PROGRAM (1, program); - - c_objcode = SCM_PROGRAM_DATA (program); - return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_objects -{ - SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_OBJTABLE (program); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_module -{ - SCM objs, mod; - SCM_VALIDATE_PROGRAM (1, program); - objs = SCM_PROGRAM_OBJTABLE (program); - /* If a program is the result of compiling GLIL to assembly, then if - it has an objtable, the first entry will be a module. But some - programs are hand-coded trampolines, like boot programs and - primitives and the like. So if a program happens to have a - non-module in the first slot of the objtable, assume that it is - such a trampoline, and just return #f for the module. */ - mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F; - return SCM_MODULEP (mod) ? mod : SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_meta -{ - SCM metaobj; - - SCM_VALIDATE_PROGRAM (1, program); - - metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); - if (scm_is_true (metaobj)) - return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program), - SCM_BOOL_F); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_bindings -{ - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_BOOL_F; - - return scm_car (scm_call_0 (meta)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_sources, "%program-sources", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_sources -{ - SCM meta, sources, ret, filename; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_EOL; - - filename = SCM_BOOL_F; - ret = SCM_EOL; - for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources); - sources = scm_cdr (sources)) - { - SCM x = scm_car (sources); - if (scm_is_pair (x)) - { - if (scm_is_number (scm_car (x))) - { - SCM addr = scm_car (x); - ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)), - ret); - } - else if (scm_is_eq (scm_car (x), scm_sym_filename)) - filename = scm_cdr (x); - } - } - return scm_reverse_x (ret, SCM_UNDEFINED); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_arities -{ - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_BOOL_F; - - return scm_caddr (scm_call_0 (meta)); -} -#undef FUNC_NAME - -SCM -scm_i_program_properties (SCM program) -#define FUNC_NAME "%program-properties" -{ - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_EOL; - - return scm_cdddr (scm_call_0 (meta)); -} -#undef FUNC_NAME - SCM scm_find_source_for_addr (SCM ip) { @@ -438,12 +235,9 @@ SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, "") #define FUNC_NAME s_scm_program_num_free_variables { - if (SCM_RTL_PROGRAM_P (program)) { - return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)); - } + SCM_VALIDATE_RTL_PROGRAM (1, program); - SCM_VALIDATE_PROGRAM (1, program); - return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program)); + return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)); } #undef FUNC_NAME @@ -454,18 +248,11 @@ SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0, { unsigned long idx; - if (SCM_RTL_PROGRAM_P (program)) { - SCM_VALIDATE_ULONG_COPY (2, i, idx); - if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) - SCM_OUT_OF_RANGE (2, i); - return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx); - } - - SCM_VALIDATE_PROGRAM (1, program); + SCM_VALIDATE_RTL_PROGRAM (1, program); SCM_VALIDATE_ULONG_COPY (2, i, idx); - if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) + if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) SCM_OUT_OF_RANGE (2, i); - return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx); + return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx); } #undef FUNC_NAME @@ -476,62 +263,17 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, { unsigned long idx; - if (SCM_RTL_PROGRAM_P (program)) { - SCM_VALIDATE_ULONG_COPY (2, i, idx); - if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) - SCM_OUT_OF_RANGE (2, i); - SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x); - return SCM_UNSPECIFIED; - } - - SCM_VALIDATE_PROGRAM (1, program); + SCM_VALIDATE_RTL_PROGRAM (1, program); SCM_VALIDATE_ULONG_COPY (2, i, idx); - if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) + if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) SCM_OUT_OF_RANGE (2, i); - SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x); + SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x); return SCM_UNSPECIFIED; } #undef FUNC_NAME -SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, - (SCM program), - "Return a @var{program}'s object code.") -#define FUNC_NAME s_scm_program_objcode -{ - SCM_VALIDATE_PROGRAM (1, program); - - return SCM_PROGRAM_OBJCODE (program); -} -#undef FUNC_NAME - -/* procedure-minimum-arity support. */ -static void -parse_arity (SCM arity, int *req, int *opt, int *rest) -{ - SCM x = scm_cddr (arity); - - if (scm_is_pair (x)) - { - *req = scm_to_int (scm_car (x)); - x = scm_cdr (x); - if (scm_is_pair (x)) - { - *opt = scm_to_int (scm_car (x)); - x = scm_cdr (x); - if (scm_is_pair (x)) - *rest = scm_is_true (scm_car (x)); - else - *rest = 0; - } - else - *opt = *rest = 0; - } - else - *req = *opt = *rest = 0; -} - -static int -scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest) +int +scm_i_program_arity (SCM program, int *req, int *opt, int *rest) { static SCM rtl_program_minimum_arity = SCM_BOOL_F; SCM l; @@ -566,41 +308,6 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest) return 1; } -int -scm_i_program_arity (SCM program, int *req, int *opt, int *rest) -{ - SCM arities; - - if (SCM_RTL_PROGRAM_P (program)) - return scm_i_rtl_program_minimum_arity (program, req, opt, rest); - - arities = scm_program_arities (program); - if (!scm_is_pair (arities)) - return 0; - - parse_arity (scm_car (arities), req, opt, rest); - arities = scm_cdr (arities); - - for (; scm_is_pair (arities); arities = scm_cdr (arities)) - { - int thisreq, thisopt, thisrest; - - parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest); - - if (thisreq < *req - || (thisreq == *req - && ((thisrest && (!*rest || thisopt > *opt)) - || (!thisrest && !*rest && thisopt > *opt)))) - { - *req = thisreq; - *opt = thisopt; - *rest = thisrest; - } - } - - return 1; -} - void diff --git a/libguile/programs.h b/libguile/programs.h index 0d33957a5..4b28b6e75 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -20,7 +20,6 @@ #define _SCM_PROGRAMS_H_ #include <libguile.h> -#include <libguile/objcodes.h> /* * The new RTL programs. @@ -64,15 +63,6 @@ SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip); #define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000 #define SCM_F_PROGRAM_IS_FOREIGN 0x2000 -#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program)) -#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x)) -#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x)) -#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3)) -#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i]) -#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v)) -#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16) -#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x))) -#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT) #define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE) #define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC) @@ -80,23 +70,11 @@ SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip); #define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION) #define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_FOREIGN) -SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables); - -SCM_API SCM scm_program_p (SCM obj); -SCM_API SCM scm_program_base (SCM program); -SCM_API SCM scm_program_meta (SCM program); -SCM_API SCM scm_program_bindings (SCM program); -SCM_API SCM scm_program_sources (SCM program); SCM_API SCM scm_program_source (SCM program, SCM ip, SCM sources); -SCM_API SCM scm_program_arities (SCM program); -SCM_API SCM scm_program_objects (SCM program); -SCM_API SCM scm_program_module (SCM program); SCM_API SCM scm_program_num_free_variables (SCM program); SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i); SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x); -SCM_API SCM scm_program_objcode (SCM program); -SCM_INTERNAL SCM scm_i_program_properties (SCM program); SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest); SCM_INTERNAL void scm_i_program_print (SCM program, SCM port, scm_print_state *pstate); diff --git a/libguile/smob.c b/libguile/smob.c index 857773c18..e13591f0f 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -32,7 +32,6 @@ #include "libguile/async.h" #include "libguile/goops.h" #include "libguile/instructions.h" -#include "libguile/objcodes.h" #include "libguile/programs.h" #include "libguile/smob.h" diff --git a/libguile/snarf.h b/libguile/snarf.h index 7843ac8da..afc4d8f2a 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -325,27 +325,6 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) #define SCM_IMMUTABLE_POINTER(c_name, ptr) \ SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr) -/* for primitive-generics, add a foreign to the end */ -#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \ - static SCM_ALIGNED (8) SCM c_name[3] = \ - { \ - SCM_PACK (scm_tc7_vector | (2 << 8)), \ - foreign, \ - SCM_BOOL_F /* the name */ \ - } - -#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \ - static SCM_ALIGNED (8) SCM_UNUSED SCM \ - scm_i_paste (c_name, _raw_cell)[] = \ - { \ - SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \ - objcode, \ - objtable, \ - freevars \ - }; \ - static SCM_UNUSED const SCM c_name = \ - SCM_PACK (& scm_i_paste (c_name, _raw_cell)) - #endif /* SCM_SUPPORT_STATIC_ALLOCATION */ diff --git a/libguile/stacks.c b/libguile/stacks.c index fd19a492a..bbdde3026 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -276,8 +276,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* FIXME: is this even possible? */ if (scm_is_true (frame) - && (SCM_PROGRAM_P (scm_frame_procedure (frame)) - || SCM_RTL_PROGRAM_P (scm_frame_procedure (frame))) + && SCM_RTL_PROGRAM_P (scm_frame_procedure (frame)) && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame))) frame = scm_frame_previous (frame); diff --git a/libguile/tags.h b/libguile/tags.h index 9e6943ed0..1c6503a4f 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -423,14 +423,14 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_dynamic_state 45 #define scm_tc7_frame 47 -#define scm_tc7_objcode 53 +#define scm_tc7_unused_53 53 #define scm_tc7_vm 55 #define scm_tc7_vm_cont 71 #define scm_tc7_unused_17 61 #define scm_tc7_unused_21 63 #define scm_tc7_rtl_program 69 -#define scm_tc7_program 79 +#define scm_tc7_unused_79 79 #define scm_tc7_weak_set 85 #define scm_tc7_weak_table 87 #define scm_tc7_array 93 diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 567bdbc3b..d657a08bd 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -19,32 +19,6 @@ /* This file is included in vm.c multiple times. */ -/* Virtual Machine - - This file contains two virtual machines. First, the old one -- the - one that is currently used, and corresponds to Guile 2.0. It's a - stack machine, meaning that most instructions pop their operands from - the top of the stack, and push results there too. - - Following it is the new virtual machine. It's a register machine, - meaning that intructions address their operands by index, and store - results in indexed slots as well. Those slots are on the stack. - It's somewhat confusing to call it a register machine, given that the - values are on the stack. Perhaps it needs a new name. - - Anyway, things are in a transitional state. We're going to try to - avoid munging the old VM very much while we flesh out the new one. - We're also going to try to make them interoperable, as much as - possible -- to have the old VM be able to call procedures for the new - VM, and vice versa. This should ease the bootstrapping process. */ - - -/* The old VM. */ -static SCM VM_NAME (SCM, SCM, SCM*, int); -/* The new VM. */ -static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t); - - #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) # define VM_USE_HOOKS 0 /* Various hooks */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) @@ -70,9 +44,6 @@ static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t); #ifndef IP_REG # define IP_REG #endif -#ifndef SP_REG -# define SP_REG -#endif #ifndef FP_REG # define FP_REG #endif @@ -126,393 +97,6 @@ static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t); SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ()) - - -/* Cache the VM's instruction, stack, and frame pointer in local variables. */ -#define CACHE_REGISTER() \ -{ \ - ip = vp->ip; \ - sp = vp->sp; \ - fp = vp->fp; \ -} - -/* Update the registers in VP, a pointer to the current VM. This must be done - at least before any GC invocation so that `vp->sp' is up-to-date and the - whole stack gets marked. */ -#define SYNC_REGISTER() \ -{ \ - vp->ip = ip; \ - vp->sp = sp; \ - vp->fp = fp; \ -} - -/* FIXME */ -#define ASSERT_VARIABLE(x) \ - VM_ASSERT (SCM_VARIABLEP (x), abort()) -#define ASSERT_BOUND_VARIABLE(x) \ - VM_ASSERT (SCM_VARIABLEP (x) \ - && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \ - abort()) - -#ifdef VM_ENABLE_PARANOID_ASSERTIONS -#define CHECK_IP() \ - do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) -#define ASSERT_ALIGNED_PROCEDURE() \ - do { if ((scm_t_bits)bp % 8) abort (); } while (0) -#define ASSERT_BOUND(x) \ - VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort()) -#else -#define CHECK_IP() -#define ASSERT_ALIGNED_PROCEDURE() -#define ASSERT_BOUND(x) -#endif - -/* Cache the object table and free variables. */ -#define CACHE_PROGRAM() \ -{ \ - if (bp != SCM_PROGRAM_DATA (program)) { \ - bp = SCM_PROGRAM_DATA (program); \ - ASSERT_ALIGNED_PROCEDURE (); \ - if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \ - objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \ - } else { \ - objects = NULL; \ - } \ - } \ -} - -#define SYNC_BEFORE_GC() \ -{ \ - SYNC_REGISTER (); \ -} - -#define SYNC_ALL() \ -{ \ - SYNC_REGISTER (); \ -} - - -/* - * Error check - */ - -/* Accesses to a program's object table. */ -#define CHECK_OBJECT(_num) -#define CHECK_FREE_VARIABLE(_num) - - -/* - * Stack operation - */ - -#ifdef VM_ENABLE_STACK_NULLING -# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]); -# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1) -# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; } -/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation - inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for - that continuation doesn't have a chance to run. It's not important on a - semantic level, but it does mess up our stack nulling -- so this macro is to - fix that. */ -# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp); -#else -# define CHECK_STACK_LEAKN(_n) -# define CHECK_STACK_LEAK() -# define NULLSTACK(_n) -# define NULLSTACK_FOR_NONLOCAL_EXIT() -#endif - -/* For this check, we don't use VM_ASSERT, because that leads to a - per-site SYNC_ALL, which is too much code growth. The real problem - of course is having to check for overflow all the time... */ -#define CHECK_OVERFLOW() \ - do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0) - -#ifdef VM_CHECK_UNDERFLOW -#define PRE_CHECK_UNDERFLOW(N) \ - VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ()) -#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0) -#else -#define PRE_CHECK_UNDERFLOW(N) /* nop */ -#define CHECK_UNDERFLOW() /* nop */ -#endif - - -#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) -#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0) -#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0) -#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0) -#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0) -#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0) - -/* Pop the N objects on top of the stack and push a list that contains - them. */ -#define POP_LIST(n) \ -do \ -{ \ - int i; \ - SCM l = SCM_EOL, x; \ - SYNC_BEFORE_GC (); \ - for (i = n; i; i--) \ - { \ - POP (x); \ - l = scm_cons (x, l); \ - } \ - PUSH (l); \ -} while (0) - -/* The opposite: push all of the elements in L onto the list. */ -#define PUSH_LIST(l, NILP) \ -do \ -{ \ - for (; scm_is_pair (l); l = SCM_CDR (l)) \ - PUSH (SCM_CAR (l)); \ - VM_ASSERT (NILP (l), vm_error_improper_list (l)); \ -} while (0) - - -/* - * Instruction operation - */ - -#define FETCH() (*ip++) -#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0) - -#undef NEXT_JUMP -#ifdef HAVE_LABELS_AS_VALUES -# define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK] -#else -# define NEXT_JUMP() goto vm_start -#endif - -#define NEXT \ -{ \ - NEXT_HOOK (); \ - CHECK_STACK_LEAK (); \ - NEXT_JUMP (); \ -} - - -/* See frames.h for the layout of stack frames */ -/* When this is called, bp points to the new program data, - and the arguments are already on the stack */ -#define DROP_FRAME() \ - { \ - sp -= 3; \ - NULLSTACK (3); \ - CHECK_UNDERFLOW (); \ - } - - -static SCM -VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) -{ - /* VM registers */ - register scm_t_uint8 *ip IP_REG; /* instruction pointer */ - register SCM *sp SP_REG; /* stack pointer */ - register SCM *fp FP_REG; /* frame pointer */ - struct scm_vm *vp = SCM_VM_DATA (vm); - - /* Cache variables */ - struct scm_objcode *bp = NULL; /* program base pointer */ - SCM *objects = NULL; /* constant objects */ - SCM *stack_limit = vp->stack_limit; /* stack limit address */ - - scm_i_thread *current_thread = SCM_I_CURRENT_THREAD; - - /* Internal variables */ - int nvalues = 0; - scm_i_jmp_buf registers; /* used for prompts */ - -#ifdef HAVE_LABELS_AS_VALUES - static const void **jump_table_pointer = NULL; -#endif - -#ifdef HAVE_LABELS_AS_VALUES - register const void **jump_table JT_REG; - - if (SCM_UNLIKELY (!jump_table_pointer)) - { - int i; - jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); - for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - jump_table_pointer[i] = &&vm_error_bad_instruction; -#define VM_INSTRUCTION_TO_LABEL 1 -#define jump_table jump_table_pointer -#include <libguile/vm-expand.h> -#include <libguile/vm-i-system.i> -#include <libguile/vm-i-scheme.i> -#include <libguile/vm-i-loader.i> -#undef jump_table -#undef VM_INSTRUCTION_TO_LABEL - } - - /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one - load instruction at each instruction dispatch. */ - jump_table = jump_table_pointer; -#endif - - if (SCM_I_SETJMP (registers)) - { - /* Non-local return. Cache the VM registers back from the vp, and - go to the handler. - - Note, at this point, we must assume that any variable local to - vm_engine that can be assigned *has* been assigned. So we need to pull - all our state back from the ip/fp/sp. - */ - CACHE_REGISTER (); - program = SCM_FRAME_PROGRAM (fp); - CACHE_PROGRAM (); - /* The stack contains the values returned to this continuation, - along with a number-of-values marker -- like an MV return. */ - ABORT_CONTINUATION_HOOK (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp)); - NEXT; - } - - CACHE_REGISTER (); - - /* Since it's possible to receive the arguments on the stack itself, - and indeed the RTL VM invokes us that way, shuffle up the - arguments first. */ - VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs)); - { - int i; - for (i = nargs - 1; i >= 0; i--) - sp[9 + i] = argv[i]; - } - - /* Initial frame */ - PUSH (SCM_PACK (fp)); /* dynamic link */ - PUSH (SCM_PACK (0)); /* mvra */ - PUSH (SCM_PACK (ip)); /* ra */ - PUSH (boot_continuation); - fp = sp + 1; - ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation)); - - /* MV-call frame, function & arguments */ - PUSH (SCM_PACK (fp)); /* dynamic link */ - PUSH (SCM_PACK (ip + 1)); /* mvra */ - PUSH (SCM_PACK (ip)); /* ra */ - PUSH (program); - fp = sp + 1; - sp += nargs; - - PUSH_CONTINUATION_HOOK (); - - apply: - program = fp[-1]; - if (!SCM_PROGRAM_P (program)) - { - if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program)) - fp[-1] = SCM_STRUCT_PROCEDURE (program); - else if (SCM_HAS_TYP7 (program, scm_tc7_rtl_program)) - { - SCM ret; - SYNC_ALL (); - - ret = RTL_VM_NAME (vm, program, fp, sp - fp + 1); - - NULLSTACK_FOR_NONLOCAL_EXIT (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - /* multiple values returned to continuation */ - ret = scm_struct_ref (ret, SCM_INUM0); - nvalues = scm_ilength (ret); - PUSH_LIST (ret, scm_is_null); - goto vm_return_values; - } - else - { - PUSH (ret); - goto vm_return; - } - } - else if (SCM_HAS_TYP7 (program, scm_tc7_smob) - && SCM_SMOB_APPLICABLE_P (program)) - { - /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */ - int i; - PUSH (SCM_BOOL_F); - for (i = sp - fp; i >= 0; i--) - fp[i] = fp[i - 1]; - fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline; - } - else - { - SYNC_ALL(); - vm_error_wrong_type_apply (program); - } - goto apply; - } - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - - /* Let's go! */ - NEXT; - -#ifndef HAVE_LABELS_AS_VALUES - vm_start: - switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) { -#endif - -#include "vm-expand.h" -#include "vm-i-system.c" -#include "vm-i-scheme.c" -#include "vm-i-loader.c" - -#ifndef HAVE_LABELS_AS_VALUES - default: - goto vm_error_bad_instruction; - } -#endif - - abort (); /* never reached */ - - vm_error_bad_instruction: - vm_error_bad_instruction (ip[-1]); - abort (); /* never reached */ - - handle_overflow: - SYNC_ALL (); - vm_error_stack_overflow (vp); - abort (); /* never reached */ -} - -#undef ALIGNED_P -#undef CACHE_REGISTER -#undef CHECK_OVERFLOW -#undef FUNC2 -#undef INIT -#undef INUM_MAX -#undef INUM_MIN -#undef INUM_STEP -#undef jump_table -#undef LOCAL_REF -#undef LOCAL_SET -#undef NEXT -#undef NEXT_JUMP -#undef REL -#undef RETURN -#undef RETURN_ONE_VALUE -#undef RETURN_VALUE_LIST -#undef SYNC_ALL -#undef SYNC_BEFORE_GC -#undef SYNC_IP -#undef SYNC_REGISTER -#undef VARIABLE_BOUNDP -#undef VARIABLE_REF -#undef VARIABLE_SET -#undef VM_DEFINE_OP -#undef VM_INSTRUCTION_TO_LABEL - - - - /* Virtual Machine This is Guile's new virtual machine. When I say "new", I mean @@ -918,22 +502,8 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) continue; } -#if 0 SYNC_IP(); vm_error_wrong_type_apply (proc); -#else - { - SCM ret; - SYNC_ALL (); - - ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); - else - RETURN_ONE_VALUE (ret); - } -#endif } /* Let's go! */ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c deleted file mode 100644 index c3231568e..000000000 --- a/libguile/vm-i-loader.c +++ /dev/null @@ -1,134 +0,0 @@ -/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - -/* FIXME! Need to check that the fetch is within the current program */ - -/* This file is included in vm_engine.c */ - -VM_DEFINE_LOADER (101, load_number, "load-number") -{ - size_t len; - - FETCH_LENGTH (len); - SYNC_REGISTER (); - PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len), - SCM_UNDEFINED /* radix = 10 */)); - /* Was: scm_istring2number (ip, len, 10)); */ - ip += len; - NEXT; -} - -VM_DEFINE_LOADER (102, load_string, "load-string") -{ - size_t len; - char *buf; - - FETCH_LENGTH (len); - SYNC_REGISTER (); - PUSH (scm_i_make_string (len, &buf, 1)); - memcpy (buf, (char *) ip, len); - ip += len; - NEXT; -} - -VM_DEFINE_LOADER (103, load_symbol, "load-symbol") -{ - size_t len; - FETCH_LENGTH (len); - SYNC_REGISTER (); - /* FIXME: should be scm_from_latin1_symboln */ - PUSH (scm_from_latin1_symboln ((const char*)ip, len)); - ip += len; - NEXT; -} - -VM_DEFINE_LOADER (104, load_program, "load-program") -{ - scm_t_uint32 len; - SCM objs, objcode; - - POP (objs); - SYNC_REGISTER (); - - if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0))) - scm_c_vector_set_x (objs, 0, scm_current_module ()); - - objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip); - len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); - - PUSH (scm_make_program (objcode, objs, SCM_BOOL_F)); - - ip += len; - - NEXT; -} - -VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1) -{ - SCM what; - POP (what); - SYNC_REGISTER (); - PUSH (resolve_variable (what, scm_current_module ())); - NEXT; -} - -VM_DEFINE_LOADER (106, load_array, "load-array") -{ - SCM type, shape; - size_t len; - FETCH_LENGTH (len); - POP2 (shape, type); - SYNC_REGISTER (); - PUSH (scm_from_contiguous_typed_array (type, shape, ip, len)); - ip += len; - NEXT; -} - -VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string") -{ - size_t len; - scm_t_wchar *wbuf; - - FETCH_LENGTH (len); - VM_ASSERT ((len % 4) == 0, - vm_error_bad_wide_string_length (len)); - - SYNC_REGISTER (); - PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1)); - memcpy ((char *) wbuf, (char *) ip, len); - ip += len; - NEXT; -} - -/* -(defun renumber-ops () - "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" - (interactive "") - (save-excursion - (let ((counter 100)) (goto-char (point-min)) - (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) - (replace-match - (number-to-string (setq counter (1+ counter))) - t t nil 1))))) -*/ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c deleted file mode 100644 index 07bb6442d..000000000 --- a/libguile/vm-i-scheme.c +++ /dev/null @@ -1,1126 +0,0 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - -/* This file is included in vm_engine.c */ - - -/* - * Predicates - */ - -#define ARGS1(a1) SCM a1 = sp[0]; -#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1); -#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2); - -#define RETURN(x) do { *sp = x; NEXT; } while (0) - -VM_DEFINE_FUNCTION (128, not, "not", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_is_false (x))); -} - -VM_DEFINE_FUNCTION (129, not_not, "not-not", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (!scm_is_false (x))); -} - -VM_DEFINE_FUNCTION (130, eq, "eq?", 2) -{ - ARGS2 (x, y); - RETURN (scm_from_bool (scm_is_eq (x, y))); -} - -VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2) -{ - ARGS2 (x, y); - RETURN (scm_from_bool (!scm_is_eq (x, y))); -} - -VM_DEFINE_FUNCTION (132, nullp, "null?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_is_null (x))); -} - -VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (!scm_is_null (x))); -} - -VM_DEFINE_FUNCTION (134, nilp, "nil?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_is_lisp_false (x))); -} - -VM_DEFINE_FUNCTION (135, not_nilp, "not-nil?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (!scm_is_lisp_false (x))); -} - -VM_DEFINE_FUNCTION (136, eqv, "eqv?", 2) -{ - ARGS2 (x, y); - if (scm_is_eq (x, y)) - RETURN (SCM_BOOL_T); - if (SCM_IMP (x) || SCM_IMP (y)) - RETURN (SCM_BOOL_F); - SYNC_REGISTER (); - RETURN (scm_eqv_p (x, y)); -} - -VM_DEFINE_FUNCTION (137, equal, "equal?", 2) -{ - ARGS2 (x, y); - if (scm_is_eq (x, y)) - RETURN (SCM_BOOL_T); - if (SCM_IMP (x) || SCM_IMP (y)) - RETURN (SCM_BOOL_F); - SYNC_REGISTER (); - RETURN (scm_equal_p (x, y)); -} - -VM_DEFINE_FUNCTION (138, pairp, "pair?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_is_pair (x))); -} - -VM_DEFINE_FUNCTION (139, listp, "list?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_ilength (x) >= 0)); -} - -VM_DEFINE_FUNCTION (140, symbolp, "symbol?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (scm_is_symbol (x))); -} - -VM_DEFINE_FUNCTION (141, vectorp, "vector?", 1) -{ - ARGS1 (x); - RETURN (scm_from_bool (SCM_I_IS_VECTOR (x))); -} - - -/* - * Basic data - */ - -VM_DEFINE_FUNCTION (142, cons, "cons", 2) -{ - ARGS2 (x, y); - SYNC_BEFORE_GC (); - x = scm_cons (x, y); - RETURN (x); -} - -#define VM_VALIDATE_CONS(x, proc) \ - VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x)) - -VM_DEFINE_FUNCTION (143, car, "car", 1) -{ - ARGS1 (x); - VM_VALIDATE_CONS (x, "car"); - RETURN (SCM_CAR (x)); -} - -VM_DEFINE_FUNCTION (144, cdr, "cdr", 1) -{ - ARGS1 (x); - VM_VALIDATE_CONS (x, "cdr"); - RETURN (SCM_CDR (x)); -} - -VM_DEFINE_INSTRUCTION (145, set_car, "set-car!", 0, 2, 0) -{ - SCM x, y; - POP2 (y, x); - VM_VALIDATE_CONS (x, "set-car!"); - SCM_SETCAR (x, y); - NEXT; -} - -VM_DEFINE_INSTRUCTION (146, set_cdr, "set-cdr!", 0, 2, 0) -{ - SCM x, y; - POP2 (y, x); - VM_VALIDATE_CONS (x, "set-cdr!"); - SCM_SETCDR (x, y); - NEXT; -} - - -/* - * Numeric relational tests - */ - -#define REL(crel,srel) \ - { \ - ARGS2 (x, y); \ - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ - RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x)) \ - crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \ - SYNC_REGISTER (); \ - RETURN (srel (x, y)); \ - } - -VM_DEFINE_FUNCTION (147, ee, "ee?", 2) -{ - REL (==, scm_num_eq_p); -} - -VM_DEFINE_FUNCTION (148, lt, "lt?", 2) -{ - REL (<, scm_less_p); -} - -VM_DEFINE_FUNCTION (149, le, "le?", 2) -{ - REL (<=, scm_leq_p); -} - -VM_DEFINE_FUNCTION (150, gt, "gt?", 2) -{ - REL (>, scm_gr_p); -} - -VM_DEFINE_FUNCTION (151, ge, "ge?", 2) -{ - REL (>=, scm_geq_p); -} - -#undef REL - - -/* - * Numeric functions - */ - -/* The maximum/minimum tagged integers. */ -#define INUM_MAX \ - ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM))) -#define INUM_MIN \ - ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM))) -#define INUM_STEP \ - ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \ - - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0)) - -#define FUNC2(CFUNC,SFUNC) \ -{ \ - ARGS2 (x, y); \ - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ - { \ - scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\ - if (SCM_FIXABLE (n)) \ - RETURN (SCM_I_MAKINUM (n)); \ - } \ - SYNC_REGISTER (); \ - RETURN (SFUNC (x, y)); \ -} - -/* Assembly tagged integer arithmetic routines. This code uses the - `asm goto' feature introduced in GCC 4.5. */ - -#if SCM_GNUC_PREREQ (4, 5) && (defined __x86_64__ || defined __i386__) - -# undef _CX -# ifdef __x86_64__ -# define _CX "rcx" -# else -# define _CX "ecx" -# endif - -/* The macros below check the CPU's overflow flag to improve fixnum - arithmetic. The _CX register (%rcx or %ecx) is explicitly - clobbered because `asm goto' can't have outputs, in which case the - `r' constraint could be used to let the register allocator choose a - register. - - TODO: Use `cold' label attribute in GCC 4.6. - http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html */ - -# define ASM_ADD(x, y) \ - { \ - asm volatile goto ("mov %1, %%"_CX"; " \ - "test %[tag], %%cl; je %l[slow_add]; " \ - "test %[tag], %0; je %l[slow_add]; " \ - "sub %[tag], %%"_CX"; " \ - "add %0, %%"_CX"; jo %l[slow_add]; " \ - "mov %%"_CX", (%[vsp])\n" \ - : /* no outputs */ \ - : "r" (x), "r" (y), \ - [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \ - : _CX, "memory", "cc" \ - : slow_add); \ - NEXT; \ - } \ - slow_add: \ - do { } while (0) - -# define ASM_SUB(x, y) \ - { \ - asm volatile goto ("mov %0, %%"_CX"; " \ - "test %[tag], %%cl; je %l[slow_sub]; " \ - "test %[tag], %1; je %l[slow_sub]; " \ - "sub %1, %%"_CX"; jo %l[slow_sub]; " \ - "add %[tag], %%"_CX"; " \ - "mov %%"_CX", (%[vsp])\n" \ - : /* no outputs */ \ - : "r" (x), "r" (y), \ - [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \ - : _CX, "memory", "cc" \ - : slow_sub); \ - NEXT; \ - } \ - slow_sub: \ - do { } while (0) - -# define ASM_MUL(x, y) \ - { \ - scm_t_signed_bits xx = SCM_I_INUM (x); \ - asm volatile goto ("mov %1, %%"_CX"; " \ - "test %[tag], %%cl; je %l[slow_mul]; " \ - "sub %[tag], %%"_CX"; " \ - "test %[tag], %0; je %l[slow_mul]; " \ - "imul %2, %%"_CX"; jo %l[slow_mul]; " \ - "add %[tag], %%"_CX"; " \ - "mov %%"_CX", (%[vsp])\n" \ - : /* no outputs */ \ - : "r" (x), "r" (y), "r" (xx), \ - [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \ - : _CX, "memory", "cc" \ - : slow_mul); \ - NEXT; \ - } \ - slow_mul: \ - do { } while (0) - -#endif - -#if SCM_GNUC_PREREQ (4, 5) && defined __arm__ - -# define ASM_ADD(x, y) \ - if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \ - { \ - asm volatile goto ("adds r0, %0, %1; bvs %l[slow_add]; " \ - "str r0, [%[vsp]]\n" \ - : /* no outputs */ \ - : "r" (x), "r" (y - scm_tc2_int), \ - [vsp] "r" (sp) \ - : "r0", "memory", "cc" \ - : slow_add); \ - NEXT; \ - } \ - slow_add: \ - do { } while (0) - -# define ASM_SUB(x, y) \ - if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \ - { \ - asm volatile goto ("subs r0, %0, %1; bvs %l[slow_sub]; " \ - "str r0, [%[vsp]]\n" \ - : /* no outputs */ \ - : "r" (x), "r" (y - scm_tc2_int), \ - [vsp] "r" (sp) \ - : "r0", "memory", "cc" \ - : slow_sub); \ - NEXT; \ - } \ - slow_sub: \ - do { } while (0) - -# if defined (__ARM_ARCH_3M__) || defined (__ARM_ARCH_4__) \ - || defined (__ARM_ARCH_4T__) || defined (__ARM_ARCH_5__) \ - || defined (__ARM_ARCH_5T__) || defined (__ARM_ARCH_5E__) \ - || defined (__ARM_ARCH_5TE__) || defined (__ARM_ARCH_5TEJ__) \ - || defined (__ARM_ARCH_6__) || defined (__ARM_ARCH_6J__) \ - || defined (__ARM_ARCH_6K__) || defined (__ARM_ARCH_6Z__) \ - || defined (__ARM_ARCH_6ZK__) || defined (__ARM_ARCH_6T2__) \ - || defined (__ARM_ARCH_6M__) || defined (__ARM_ARCH_7__) \ - || defined (__ARM_ARCH_7A__) || defined (__ARM_ARCH_7R__) \ - || defined (__ARM_ARCH_7M__) || defined (__ARM_ARCH_7EM__) \ - || defined (__ARM_ARCH_8A__) - -/* The ARM architectures listed above support the SMULL instruction */ - -# define ASM_MUL(x, y) \ - if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \ - { \ - scm_t_signed_bits rlo, rhi; \ - asm ("smull %0, %1, %2, %3\n" \ - : "=r" (rlo), "=r" (rhi) \ - : "r" (SCM_UNPACK (x) - scm_tc2_int), \ - "r" (SCM_I_INUM (y))); \ - if (SCM_LIKELY (SCM_SRS (rlo, 31) == rhi)) \ - RETURN (SCM_PACK (rlo + scm_tc2_int)); \ - } \ - do { } while (0) - -# endif - -#endif - -VM_DEFINE_FUNCTION (152, add, "add", 2) -{ -#ifndef ASM_ADD - FUNC2 (+, scm_sum); -#else - ARGS2 (x, y); - ASM_ADD (x, y); - SYNC_REGISTER (); - RETURN (scm_sum (x, y)); -#endif -} - -VM_DEFINE_FUNCTION (153, add1, "add1", 1) -{ - ARGS1 (x); - - /* Check for overflow. We must avoid overflow in the signed - addition below, even if X is not an inum. */ - if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP)) - { - SCM result; - - /* Add 1 to the integer without untagging. */ - result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP); - - if (SCM_LIKELY (SCM_I_INUMP (result))) - RETURN (result); - } - - SYNC_REGISTER (); - RETURN (scm_sum (x, SCM_I_MAKINUM (1))); -} - -VM_DEFINE_FUNCTION (154, sub, "sub", 2) -{ -#ifndef ASM_SUB - FUNC2 (-, scm_difference); -#else - ARGS2 (x, y); - ASM_SUB (x, y); - SYNC_REGISTER (); - RETURN (scm_difference (x, y)); -#endif -} - -VM_DEFINE_FUNCTION (155, sub1, "sub1", 1) -{ - ARGS1 (x); - - /* Check for overflow. We must avoid overflow in the signed - subtraction below, even if X is not an inum. */ - if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP)) - { - SCM result; - - /* Substract 1 from the integer without untagging. */ - result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP); - - if (SCM_LIKELY (SCM_I_INUMP (result))) - RETURN (result); - } - - SYNC_REGISTER (); - RETURN (scm_difference (x, SCM_I_MAKINUM (1))); -} - -VM_DEFINE_FUNCTION (156, mul, "mul", 2) -{ - ARGS2 (x, y); -#ifdef ASM_MUL - ASM_MUL (x, y); -#endif - SYNC_REGISTER (); - RETURN (scm_product (x, y)); -} - -#undef ASM_ADD -#undef ASM_SUB -#undef ASM_MUL -#undef FUNC2 -#undef INUM_MAX -#undef INUM_MIN -#undef INUM_STEP - -VM_DEFINE_FUNCTION (157, div, "div", 2) -{ - ARGS2 (x, y); - SYNC_REGISTER (); - RETURN (scm_divide (x, y)); -} - -VM_DEFINE_FUNCTION (158, quo, "quo", 2) -{ - ARGS2 (x, y); - SYNC_REGISTER (); - RETURN (scm_quotient (x, y)); -} - -VM_DEFINE_FUNCTION (159, rem, "rem", 2) -{ - ARGS2 (x, y); - SYNC_REGISTER (); - RETURN (scm_remainder (x, y)); -} - -VM_DEFINE_FUNCTION (160, mod, "mod", 2) -{ - ARGS2 (x, y); - SYNC_REGISTER (); - RETURN (scm_modulo (x, y)); -} - -VM_DEFINE_FUNCTION (161, ash, "ash", 2) -{ - ARGS2 (x, y); - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) - { - if (SCM_I_INUM (y) < 0) - /* Right shift, will be a fixnum. */ - RETURN (SCM_I_MAKINUM - (SCM_SRS (SCM_I_INUM (x), - (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1) - ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1))); - else - /* Left shift. See comments in scm_ash. */ - { - scm_t_signed_bits nn, bits_to_shift; - - nn = SCM_I_INUM (x); - bits_to_shift = SCM_I_INUM (y); - - if (bits_to_shift < SCM_I_FIXNUM_BIT-1 - && ((scm_t_bits) - (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) - <= 1)) - RETURN (SCM_I_MAKINUM (nn << bits_to_shift)); - /* fall through */ - } - /* fall through */ - } - SYNC_REGISTER (); - RETURN (scm_ash (x, y)); -} - -VM_DEFINE_FUNCTION (162, logand, "logand", 2) -{ - ARGS2 (x, y); - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) - /* Compute bitwise AND without untagging */ - RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y))); - SYNC_REGISTER (); - RETURN (scm_logand (x, y)); -} - -VM_DEFINE_FUNCTION (163, logior, "logior", 2) -{ - ARGS2 (x, y); - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) - /* Compute bitwise OR without untagging */ - RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y))); - SYNC_REGISTER (); - RETURN (scm_logior (x, y)); -} - -VM_DEFINE_FUNCTION (164, logxor, "logxor", 2) -{ - ARGS2 (x, y); - if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) - RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y))); - SYNC_REGISTER (); - RETURN (scm_logxor (x, y)); -} - - -/* - * Strings - */ - -VM_DEFINE_FUNCTION (165, string_length, "string-length", 1) -{ - ARGS1 (str); - if (SCM_LIKELY (scm_is_string (str))) - RETURN (SCM_I_MAKINUM (scm_i_string_length (str))); - else - { - SYNC_REGISTER (); - RETURN (scm_string_length (str)); - } -} - -VM_DEFINE_FUNCTION (166, string_ref, "string-ref", 2) -{ - scm_t_signed_bits i = 0; - ARGS2 (str, idx); - if (SCM_LIKELY (scm_is_string (str) - && SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < scm_i_string_length (str))) - RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i))); - else - { - SYNC_REGISTER (); - RETURN (scm_string_ref (str, idx)); - } -} - -/* No string-set! instruction, as there is no good fast path there. */ - - -/* - * Vectors and arrays - */ - -VM_DEFINE_FUNCTION (167, vector_length, "vector-length", 1) -{ - ARGS1 (vect); - if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) - RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect))); - else - { - SYNC_REGISTER (); - RETURN (scm_vector_length (vect)); - } -} - -VM_DEFINE_FUNCTION (168, vector_ref, "vector-ref", 2) -{ - scm_t_signed_bits i = 0; - ARGS2 (vect, idx); - if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect) - && SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect))) - RETURN (SCM_I_VECTOR_ELTS (vect)[i]); - else - { - SYNC_REGISTER (); - RETURN (scm_vector_ref (vect, idx)); - } -} - -VM_DEFINE_INSTRUCTION (169, vector_set, "vector-set", 0, 3, 0) -{ - scm_t_signed_bits i = 0; - SCM vect, idx, val; - POP3 (val, idx, vect); - if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect) - && SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect))) - SCM_I_VECTOR_WELTS (vect)[i] = val; - else - { - SYNC_REGISTER (); - scm_vector_set_x (vect, idx, val); - } - NEXT; -} - -VM_DEFINE_INSTRUCTION (170, make_array, "make-array", 3, -1, 1) -{ - scm_t_uint32 len; - SCM shape, ret; - - len = FETCH (); - len = (len << 8) + FETCH (); - len = (len << 8) + FETCH (); - POP (shape); - SYNC_REGISTER (); - PRE_CHECK_UNDERFLOW (len); - ret = scm_from_contiguous_array (shape, sp - len + 1, len); - DROPN (len); - PUSH (ret); - NEXT; -} - - -/* - * Structs - */ -#define VM_VALIDATE_STRUCT(obj, proc) \ - VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_struct (proc, obj)) - -VM_DEFINE_FUNCTION (171, struct_p, "struct?", 1) -{ - ARGS1 (obj); - RETURN (scm_from_bool (SCM_STRUCTP (obj))); -} - -VM_DEFINE_FUNCTION (172, struct_vtable, "struct-vtable", 1) -{ - ARGS1 (obj); - VM_VALIDATE_STRUCT (obj, "struct_vtable"); - RETURN (SCM_STRUCT_VTABLE (obj)); -} - -VM_DEFINE_INSTRUCTION (173, make_struct, "make-struct", 2, -1, 1) -{ - unsigned h = FETCH (); - unsigned l = FETCH (); - scm_t_bits n = ((h << 8U) + l); - SCM vtable = sp[-(n - 1)]; - const SCM *inits = sp - n + 2; - SCM ret; - - SYNC_REGISTER (); - - if (SCM_LIKELY (SCM_STRUCTP (vtable) - && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) - && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1 - == n) - && !SCM_VTABLE_INSTANCE_FINALIZER (vtable))) - { - /* Verily, we are making a simple struct with the right number of - initializers, and no finalizer. */ - ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct, - n + 1); - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); - memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM)); - } - else - ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits); - - DROPN (n); - PUSH (ret); - - NEXT; -} - -VM_DEFINE_FUNCTION (174, struct_ref, "struct-ref", 2) -{ - ARGS2 (obj, pos); - - if (SCM_LIKELY (SCM_STRUCTP (obj) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE) - && SCM_I_INUMP (pos))) - { - SCM vtable; - scm_t_bits index, len; - - /* True, an inum is a signed value, but cast to unsigned it will - certainly be more than the length, so we will fall through if - index is negative. */ - index = SCM_I_INUM (pos); - vtable = SCM_STRUCT_VTABLE (obj); - len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - - if (SCM_LIKELY (index < len)) - { - scm_t_bits *data = SCM_STRUCT_DATA (obj); - RETURN (SCM_PACK (data[index])); - } - } - - SYNC_REGISTER (); - RETURN (scm_struct_ref (obj, pos)); -} - -VM_DEFINE_FUNCTION (175, struct_set, "struct-set", 3) -{ - ARGS3 (obj, pos, val); - - if (SCM_LIKELY (SCM_STRUCTP (obj) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE_RW) - && SCM_I_INUMP (pos))) - { - SCM vtable; - scm_t_bits index, len; - - /* See above regarding index being >= 0. */ - index = SCM_I_INUM (pos); - vtable = SCM_STRUCT_VTABLE (obj); - len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); - if (SCM_LIKELY (index < len)) - { - scm_t_bits *data = SCM_STRUCT_DATA (obj); - data[index] = SCM_UNPACK (val); - RETURN (val); - } - } - - SYNC_REGISTER (); - RETURN (scm_struct_set_x (obj, pos, val)); -} - - -/* - * GOOPS support - */ -VM_DEFINE_FUNCTION (176, class_of, "class-of", 1) -{ - ARGS1 (obj); - if (SCM_INSTANCEP (obj)) - RETURN (SCM_CLASS_OF (obj)); - SYNC_REGISTER (); - RETURN (scm_class_of (obj)); -} - -/* FIXME: No checking whatsoever. */ -VM_DEFINE_FUNCTION (177, slot_ref, "slot-ref", 2) -{ - size_t slot; - ARGS2 (instance, idx); - slot = SCM_I_INUM (idx); - RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); -} - -/* FIXME: No checking whatsoever. */ -VM_DEFINE_INSTRUCTION (178, slot_set, "slot-set", 0, 3, 0) -{ - SCM instance, idx, val; - size_t slot; - POP3 (val, idx, instance); - slot = SCM_I_INUM (idx); - SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val); - NEXT; -} - - -/* - * Bytevectors - */ -#define VM_VALIDATE_BYTEVECTOR(x, proc) \ - VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x)) - -#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \ -{ \ - SCM endianness; \ - POP (endianness); \ - if (scm_is_eq (endianness, scm_i_native_endianness)) \ - goto VM_LABEL (bv_##stem##_native_ref); \ - { \ - ARGS2 (bv, idx); \ - SYNC_REGISTER (); \ - RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \ - } \ -} - -/* Return true (non-zero) if PTR has suitable alignment for TYPE. */ -#define ALIGNED_P(ptr, type) \ - ((scm_t_uintptr) (ptr) % alignof_type (type) == 0) - -VM_DEFINE_FUNCTION (179, bv_u16_ref, "bv-u16-ref", 3) -BV_REF_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_FUNCTION (180, bv_s16_ref, "bv-s16-ref", 3) -BV_REF_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_FUNCTION (181, bv_u32_ref, "bv-u32-ref", 3) -BV_REF_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_FUNCTION (182, bv_s32_ref, "bv-s32-ref", 3) -BV_REF_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_FUNCTION (183, bv_u64_ref, "bv-u64-ref", 3) -BV_REF_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_FUNCTION (184, bv_s64_ref, "bv-s64-ref", 3) -BV_REF_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_FUNCTION (185, bv_f32_ref, "bv-f32-ref", 3) -BV_REF_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_FUNCTION (186, bv_f64_ref, "bv-f64-ref", 3) -BV_REF_WITH_ENDIANNESS (f64, ieee_double) - -#undef BV_REF_WITH_ENDIANNESS - -#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ -{ \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - RETURN (SCM_I_MAKINUM (*int_ptr)); \ - else \ - { \ - SYNC_REGISTER (); \ - RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \ - } \ -} - -#define BV_INT_REF(stem, type, size) \ -{ \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - { \ - scm_t_ ## type x = *int_ptr; \ - if (SCM_FIXABLE (x)) \ - RETURN (SCM_I_MAKINUM (x)); \ - else \ - { \ - SYNC_REGISTER (); \ - RETURN (scm_from_ ## type (x)); \ - } \ - } \ - else \ - { \ - SYNC_REGISTER (); \ - RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \ - } \ -} - -#define BV_FLOAT_REF(stem, fn_stem, type, size) \ -{ \ - scm_t_signed_bits i; \ - const type *float_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - SYNC_REGISTER (); \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (float_ptr, type)))) \ - RETURN (scm_from_double (*float_ptr)); \ - else \ - RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ -} - -VM_DEFINE_FUNCTION (187, bv_u8_ref, "bv-u8-ref", 2) -BV_FIXABLE_INT_REF (u8, u8, uint8, 1) -VM_DEFINE_FUNCTION (188, bv_s8_ref, "bv-s8-ref", 2) -BV_FIXABLE_INT_REF (s8, s8, int8, 1) -VM_DEFINE_FUNCTION (189, bv_u16_native_ref, "bv-u16-native-ref", 2) -BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) -VM_DEFINE_FUNCTION (190, bv_s16_native_ref, "bv-s16-native-ref", 2) -BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) -VM_DEFINE_FUNCTION (191, bv_u32_native_ref, "bv-u32-native-ref", 2) -#if SIZEOF_VOID_P > 4 -BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4) -#else -BV_INT_REF (u32, uint32, 4) -#endif -VM_DEFINE_FUNCTION (192, bv_s32_native_ref, "bv-s32-native-ref", 2) -#if SIZEOF_VOID_P > 4 -BV_FIXABLE_INT_REF (s32, s32_native, int32, 4) -#else -BV_INT_REF (s32, int32, 4) -#endif -VM_DEFINE_FUNCTION (193, bv_u64_native_ref, "bv-u64-native-ref", 2) -BV_INT_REF (u64, uint64, 8) -VM_DEFINE_FUNCTION (194, bv_s64_native_ref, "bv-s64-native-ref", 2) -BV_INT_REF (s64, int64, 8) -VM_DEFINE_FUNCTION (195, bv_f32_native_ref, "bv-f32-native-ref", 2) -BV_FLOAT_REF (f32, ieee_single, float, 4) -VM_DEFINE_FUNCTION (196, bv_f64_native_ref, "bv-f64-native-ref", 2) -BV_FLOAT_REF (f64, ieee_double, double, 8) - -#undef BV_FIXABLE_INT_REF -#undef BV_INT_REF -#undef BV_FLOAT_REF - - - -#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \ -{ \ - SCM endianness; \ - POP (endianness); \ - if (scm_is_eq (endianness, scm_i_native_endianness)) \ - goto VM_LABEL (bv_##stem##_native_set); \ - { \ - SCM bv, idx, val; POP3 (val, idx, bv); \ - SYNC_REGISTER (); \ - scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \ - NEXT; \ - } \ -} - -VM_DEFINE_INSTRUCTION (197, bv_u16_set, "bv-u16-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (u16, u16) -VM_DEFINE_INSTRUCTION (198, bv_s16_set, "bv-s16-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (s16, s16) -VM_DEFINE_INSTRUCTION (199, bv_u32_set, "bv-u32-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (u32, u32) -VM_DEFINE_INSTRUCTION (200, bv_s32_set, "bv-s32-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (s32, s32) -VM_DEFINE_INSTRUCTION (201, bv_u64_set, "bv-u64-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (u64, u64) -VM_DEFINE_INSTRUCTION (202, bv_s64_set, "bv-s64-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (s64, s64) -VM_DEFINE_INSTRUCTION (203, bv_f32_set, "bv-f32-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (f32, ieee_single) -VM_DEFINE_INSTRUCTION (204, bv_f64_set, "bv-f64-set", 0, 4, 0) -BV_SET_WITH_ENDIANNESS (f64, ieee_double) - -#undef BV_SET_WITH_ENDIANNESS - -#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ -{ \ - scm_t_signed_bits i, j = 0; \ - SCM bv, idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - POP3 (val, idx, bv); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)) \ - && (SCM_I_INUMP (val)) \ - && ((j = SCM_I_INUM (val)) >= min) \ - && (j <= max))) \ - *int_ptr = (scm_t_ ## type) j; \ - else \ - { \ - SYNC_REGISTER (); \ - scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \ - } \ - NEXT; \ -} - -#define BV_INT_SET(stem, type, size) \ -{ \ - scm_t_signed_bits i = 0; \ - SCM bv, idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - POP3 (val, idx, bv); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - *int_ptr = scm_to_ ## type (val); \ - else \ - { \ - SYNC_REGISTER (); \ - scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \ - } \ - NEXT; \ -} - -#define BV_FLOAT_SET(stem, fn_stem, type, size) \ -{ \ - scm_t_signed_bits i = 0; \ - SCM bv, idx, val; \ - type *float_ptr; \ - \ - POP3 (val, idx, bv); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ - i = SCM_I_INUM (idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (float_ptr, type)))) \ - *float_ptr = scm_to_double (val); \ - else \ - { \ - SYNC_REGISTER (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \ - } \ - NEXT; \ -} - -VM_DEFINE_INSTRUCTION (205, bv_u8_set, "bv-u8-set", 0, 3, 0) -BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) -VM_DEFINE_INSTRUCTION (206, bv_s8_set, "bv-s8-set", 0, 3, 0) -BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) -VM_DEFINE_INSTRUCTION (207, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) -BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) -VM_DEFINE_INSTRUCTION (208, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) -BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) -VM_DEFINE_INSTRUCTION (209, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) -#if SIZEOF_VOID_P > 4 -BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4) -#else -BV_INT_SET (u32, uint32, 4) -#endif -VM_DEFINE_INSTRUCTION (210, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) -#if SIZEOF_VOID_P > 4 -BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4) -#else -BV_INT_SET (s32, int32, 4) -#endif -VM_DEFINE_INSTRUCTION (211, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) -BV_INT_SET (u64, uint64, 8) -VM_DEFINE_INSTRUCTION (212, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) -BV_INT_SET (s64, int64, 8) -VM_DEFINE_INSTRUCTION (213, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) -BV_FLOAT_SET (f32, ieee_single, float, 4) -VM_DEFINE_INSTRUCTION (214, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) -BV_FLOAT_SET (f64, ieee_double, double, 8) - -#undef BV_FIXABLE_INT_SET -#undef BV_INT_SET -#undef BV_FLOAT_SET - -#undef ALIGNED_P -#undef VM_VALIDATE_BYTEVECTOR - -#undef VM_VALIDATE_STRUCT -#undef VM_VALIDATE_CONS - -#undef ARGS1 -#undef ARGS2 -#undef ARGS3 -#undef RETURN - -/* -(defun renumber-ops () - "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" - (interactive "") - (save-excursion - (let ((counter 127)) (goto-char (point-min)) - (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) - (replace-match - (number-to-string (setq counter (1+ counter))) - t t nil 1))))) -*/ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c deleted file mode 100644 index e023d562b..000000000 --- a/libguile/vm-i-system.c +++ /dev/null @@ -1,1656 +0,0 @@ -/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - -/* This file is included in vm_engine.c */ - - -/* - * Basic operations - */ - -VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) -{ - NEXT; -} - -VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) -{ - SCM ret; - - nvalues = SCM_I_INUM (*sp--); - NULLSTACK (1); - - if (nvalues == 1) - POP (ret); - else - { - SYNC_REGISTER (); - sp -= nvalues; - CHECK_UNDERFLOW (); - ret = scm_c_values (sp + 1, nvalues); - NULLSTACK (nvalues); - } - - { -#ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp = sp; -#endif - - /* Restore registers */ - sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - /* Setting the ip here doesn't actually affect control flow, as the calling - code will restore its own registers, but it does help when walking the - stack */ - ip = SCM_FRAME_RETURN_ADDRESS (fp); - fp = SCM_FRAME_DYNAMIC_LINK (fp); - NULLSTACK (old_sp - sp); - } - - SYNC_ALL (); - return ret; -} - -VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0) -{ - DROP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1) -{ - SCM x = *sp; - PUSH (x); - NEXT; -} - - -/* - * Object creation - */ - -VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1) -{ - PUSH (SCM_UNSPECIFIED); - NEXT; -} - -VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1) -{ - PUSH (SCM_BOOL_T); - NEXT; -} - -VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1) -{ - PUSH (SCM_BOOL_F); - NEXT; -} - -VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1) -{ - PUSH (SCM_ELISP_NIL); - NEXT; -} - -VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) -{ - PUSH (SCM_EOL); - NEXT; -} - -VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1) -{ - PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); - NEXT; -} - -VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1) -{ - PUSH (SCM_INUM0); - NEXT; -} - -VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1) -{ - PUSH (SCM_I_MAKINUM (1)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) -{ - int h = FETCH (); - int l = FETCH (); - PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) -{ - scm_t_uint64 v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (scm_from_int64 ((scm_t_int64) v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) -{ - scm_t_uint64 v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (scm_from_uint64 (v)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) -{ - scm_t_uint8 v = 0; - v = FETCH (); - - PUSH (SCM_MAKE_CHAR (v)); - /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The - contents of SCM_MAKE_CHAR may be evaluated more than once, - resulting in a double fetch. */ - NEXT; -} - -VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) -{ - scm_t_wchar v = 0; - v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - v <<= 8; v += FETCH (); - PUSH (SCM_MAKE_CHAR (v)); - NEXT; -} - - - -VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) -{ - unsigned h = FETCH (); - unsigned l = FETCH (); - unsigned len = ((h << 8) + l); - POP_LIST (len); - NEXT; -} - -VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) -{ - unsigned h = FETCH (); - unsigned l = FETCH (); - unsigned len = ((h << 8) + l); - SCM vect; - - SYNC_REGISTER (); - sp++; sp -= len; - CHECK_UNDERFLOW (); - vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F); - memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len); - NULLSTACK (len); - *sp = vect; - - NEXT; -} - - -/* - * Variable access - */ - -#define OBJECT_REF(i) objects[i] -#define OBJECT_SET(i,o) objects[i] = o - -#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) -#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o - -/* For the variable operations, we _must_ obviously avoid function calls to - `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do - nothing more than the corresponding macros. */ -#define VARIABLE_REF(v) SCM_VARIABLE_REF (v) -#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) -#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) - -#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i) - -/* ref */ - -VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) -{ - register unsigned objnum = FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); - NEXT; -} - -/* FIXME: necessary? elt 255 of the vector could be a vector... */ -VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) -{ - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - PUSH (OBJECT_REF (objnum)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1) -{ - PUSH (LOCAL_REF (FETCH ())); - ASSERT_BOUND (*sp); - NEXT; -} - -VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) -{ - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - PUSH (LOCAL_REF (i)); - ASSERT_BOUND (*sp); - NEXT; -} - -VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) -{ - PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) -{ - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED))); - NEXT; -} - -VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1) -{ - SCM x = *sp; - - /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because, - unlike in top-variable-ref, it really isn't an internal assertion - that can be optimized out -- the variable could be coming directly - from the user. */ - VM_ASSERT (SCM_VARIABLEP (x), - vm_error_not_a_variable ("variable-ref", x)); - - if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x))) - { - SCM var_name; - - SYNC_ALL (); - /* Attempt to provide the variable name in the error message. */ - var_name = scm_module_reverse_lookup (scm_current_module (), x); - vm_error_unbound (program, scm_is_true (var_name) ? var_name : x); - } - else - { - SCM o = VARIABLE_REF (x); - *sp = o; - } - - NEXT; -} - -VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1) -{ - SCM x = *sp; - - VM_ASSERT (SCM_VARIABLEP (x), - vm_error_not_a_variable ("variable-bound?", x)); - - *sp = scm_from_bool (VARIABLE_BOUNDP (x)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) -{ - unsigned objnum = FETCH (); - SCM what, resolved; - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - resolved = resolve_variable (what, scm_program_module (program)); - VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what)); - what = resolved; - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) -{ - SCM what, resolved; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_REGISTER (); - resolved = resolve_variable (what, scm_program_module (program)); - VM_ASSERT (VARIABLE_BOUNDP (resolved), - vm_error_unbound (program, what)); - what = resolved; - OBJECT_SET (objnum, what); - } - - PUSH (VARIABLE_REF (what)); - NEXT; -} - -/* set */ - -VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0) -{ - SCM x; - POP (x); - LOCAL_SET (FETCH (), x); - NEXT; -} - -VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) -{ - SCM x; - unsigned int i = FETCH (); - i <<= 8; - i += FETCH (); - POP (x); - LOCAL_SET (i, x); - NEXT; -} - -VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0) -{ - VM_ASSERT (SCM_VARIABLEP (sp[0]), - vm_error_not_a_variable ("variable-set!", sp[0])); - VARIABLE_SET (sp[0], sp[-1]); - DROPN (2); - NEXT; -} - -VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) -{ - unsigned objnum = FETCH (); - SCM what; - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) -{ - SCM what; - unsigned int objnum = FETCH (); - objnum <<= 8; - objnum += FETCH (); - CHECK_OBJECT (objnum); - what = OBJECT_REF (objnum); - - if (!SCM_VARIABLEP (what)) - { - SYNC_BEFORE_GC (); - what = resolve_variable (what, scm_program_module (program)); - OBJECT_SET (objnum, what); - } - - VARIABLE_SET (what, *sp); - DROP (); - NEXT; -} - - -/* - * branch and jump - */ - -/* offset must be at least 24 bits wide, and signed */ -#define FETCH_OFFSET(offset) \ -{ \ - offset = FETCH () << 16; \ - offset += FETCH () << 8; \ - offset += FETCH (); \ - offset -= (offset & (1<<23)) << 1; \ -} - -#define BR(p) \ -{ \ - scm_t_int32 offset; \ - FETCH_OFFSET (offset); \ - if (p) \ - ip += offset; \ - if (offset < 0) \ - VM_HANDLE_INTERRUPTS; \ - NEXT; \ -} - -VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0) -{ - scm_t_int32 offset; - FETCH_OFFSET (offset); - ip += offset; - if (offset < 0) - VM_HANDLE_INTERRUPTS; - NEXT; -} - -VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_true (x)); -} - -VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_false (x)); -} - -VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0) -{ - SCM x, y; - POP2 (y, x); - BR (scm_is_eq (x, y)); -} - -VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0) -{ - SCM x, y; - POP2 (y, x); - BR (!scm_is_eq (x, y)); -} - -VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_null (x)); -} - -VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) -{ - SCM x; - POP (x); - BR (!scm_is_null (x)); -} - -VM_DEFINE_INSTRUCTION (41, br_if_nil, "br-if-nil", 3, 0, 0) -{ - SCM x; - POP (x); - BR (scm_is_lisp_false (x)); -} - -VM_DEFINE_INSTRUCTION (42, br_if_not_nil, "br-if-not-nil", 3, 0, 0) -{ - SCM x; - POP (x); - BR (!scm_is_lisp_false (x)); -} - -#undef BR - - -/* - * Subprogram call - */ - -VM_DEFINE_INSTRUCTION (43, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) != n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (44, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) < n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (45, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) -{ - scm_t_ptrdiff n; - scm_t_int32 offset; - - n = FETCH () << 8; - n += FETCH (); - FETCH_OFFSET (offset); - if (sp - (fp - 1) > n) - ip += offset; - NEXT; -} - -VM_DEFINE_INSTRUCTION (46, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - VM_ASSERT (sp - (fp - 1) == n, - vm_error_wrong_num_args (program)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (47, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - VM_ASSERT (sp - (fp - 1) >= n, - vm_error_wrong_num_args (program)); - NEXT; -} - -VM_DEFINE_INSTRUCTION (48, bind_optionals, "bind-optionals", 2, -1, -1) -{ - scm_t_ptrdiff n; - n = FETCH () << 8; - n += FETCH (); - while (sp - (fp - 1) < n) - PUSH (SCM_UNDEFINED); - NEXT; -} - -VM_DEFINE_INSTRUCTION (49, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) -{ - SCM *walk; - scm_t_ptrdiff nreq, nreq_and_opt, ntotal; - nreq = FETCH () << 8; - nreq += FETCH (); - nreq_and_opt = FETCH () << 8; - nreq_and_opt += FETCH (); - ntotal = FETCH () << 8; - ntotal += FETCH (); - - /* look in optionals for first keyword or last positional */ - /* starting after the last required positional arg */ - walk = fp + nreq; - while (/* while we have args */ - walk <= sp - /* and we still have positionals to fill */ - && walk - fp < nreq_and_opt - /* and we haven't reached a keyword yet */ - && !scm_is_keyword (*walk)) - /* bind this optional arg (by leaving it in place) */ - walk++; - /* now shuffle up, from walk to ntotal */ - { - scm_t_ptrdiff nshuf = sp - walk + 1, i; - sp = (fp - 1) + ntotal + nshuf; - CHECK_OVERFLOW (); - for (i = 0; i < nshuf; i++) - sp[-i] = walk[nshuf-i-1]; - } - /* and fill optionals & keyword args with SCM_UNDEFINED */ - while (walk <= (fp - 1) + ntotal) - *walk++ = SCM_UNDEFINED; - - NEXT; -} - -/* See also bind-optionals/shuffle-or-br below. */ - -/* Flags that determine whether other keywords are allowed, and whether a - rest argument is expected. These values must match those used by the - glil->assembly compiler. */ -#define F_ALLOW_OTHER_KEYS 1 -#define F_REST 2 - -VM_DEFINE_INSTRUCTION (50, bind_kwargs, "bind-kwargs", 5, 0, 0) -{ - scm_t_uint16 idx; - scm_t_ptrdiff nkw; - int kw_and_rest_flags; - SCM kw; - idx = FETCH () << 8; - idx += FETCH (); - /* XXX: We don't actually use NKW. */ - nkw = FETCH () << 8; - nkw += FETCH (); - kw_and_rest_flags = FETCH (); - - VM_ASSERT ((kw_and_rest_flags & F_REST) - || ((sp - (fp - 1) - nkw) % 2) == 0, - vm_error_kwargs_length_not_even (program)) - - CHECK_OBJECT (idx); - kw = OBJECT_REF (idx); - - /* Switch NKW to be a negative index below SP. */ - for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) - { - SCM walk; - - if (scm_is_keyword (sp[nkw])) - { - for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) - { - if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) - { - SCM si = SCM_CDAR (walk); - LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), - sp[nkw + 1]); - break; - } - } - VM_ASSERT (scm_is_pair (walk) - || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), - vm_error_kwargs_unrecognized_keyword (program, sp[nkw])); - nkw++; - } - else - VM_ASSERT (kw_and_rest_flags & F_REST, - vm_error_kwargs_invalid_keyword (program, sp[nkw])); - } - - NEXT; -} - -#undef F_ALLOW_OTHER_KEYS -#undef F_REST - - -VM_DEFINE_INSTRUCTION (51, push_rest, "push-rest", 2, -1, -1) -{ - scm_t_ptrdiff n; - SCM rest = SCM_EOL; - n = FETCH () << 8; - n += FETCH (); - SYNC_BEFORE_GC (); - while (sp - (fp - 1) > n) - /* No need to check for underflow. */ - rest = scm_cons (*sp--, rest); - PUSH (rest); - NEXT; -} - -VM_DEFINE_INSTRUCTION (52, bind_rest, "bind-rest", 4, -1, -1) -{ - scm_t_ptrdiff n; - scm_t_uint32 i; - SCM rest = SCM_EOL; - n = FETCH () << 8; - n += FETCH (); - i = FETCH () << 8; - i += FETCH (); - SYNC_BEFORE_GC (); - while (sp - (fp - 1) > n) - /* No need to check for underflow. */ - rest = scm_cons (*sp--, rest); - LOCAL_SET (i, rest); - NEXT; -} - -VM_DEFINE_INSTRUCTION (53, reserve_locals, "reserve-locals", 2, -1, -1) -{ - SCM *old_sp; - scm_t_int32 n; - n = FETCH () << 8; - n += FETCH (); - old_sp = sp; - sp = (fp - 1) + n; - - if (old_sp < sp) - { - CHECK_OVERFLOW (); - while (old_sp < sp) - *++old_sp = SCM_UNDEFINED; - } - else - NULLSTACK (old_sp - sp); - - NEXT; -} - -VM_DEFINE_INSTRUCTION (54, new_frame, "new-frame", 0, 0, 3) -{ - /* NB: if you change this, see frames.c:vm-frame-num-locals */ - /* and frames.h, vm-engine.c, etc of course */ - - /* We don't initialize the dynamic link here because we don't actually - know that this frame will point to the current fp: it could be - placed elsewhere on the stack if captured in a partial - continuation, and invoked from some other context. */ - PUSH (SCM_PACK (0)); /* dynamic link */ - PUSH (SCM_PACK (0)); /* mvra */ - PUSH (SCM_PACK (0)); /* ra */ - NEXT; -} - -VM_DEFINE_INSTRUCTION (55, call, "call", 1, -1, 1) -{ - nargs = FETCH (); - - vm_call: - VM_HANDLE_INTERRUPTS; - - { - SCM *old_fp = fp; - - fp = sp - nargs + 1; - - ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); - ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); - ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); - SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); - } - - PUSH_CONTINUATION_HOOK (); - - program = fp[-1]; - - if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) - goto apply; - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (56, tail_call, "tail-call", 1, -1, 1) -{ - nargs = FETCH (); - - vm_tail_call: - VM_HANDLE_INTERRUPTS; - - { - int i; -#ifdef VM_ENABLE_STACK_NULLING - SCM *old_sp = sp; - CHECK_STACK_LEAK (); -#endif - - /* shuffle down the program and the arguments */ - for (i = -1, sp = sp - nargs + 1; i < nargs; i++) - SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i]; - - sp = fp + i - 1; - - NULLSTACK (old_sp - sp); - } - - program = fp[-1]; - - if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) - goto apply; - - CACHE_PROGRAM (); - ip = SCM_C_OBJCODE_BASE (bp); - - APPLY_HOOK (); - NEXT; -} - -VM_DEFINE_INSTRUCTION (57, subr_call, "subr-call", 1, -1, -1) -{ - SCM pointer, ret; - SCM (*subr)(); - - nargs = FETCH (); - POP (pointer); - - subr = SCM_POINTER_VALUE (pointer); - - VM_HANDLE_INTERRUPTS; - SYNC_REGISTER (); - - switch (nargs) - { - case 0: - ret = subr (); - break; - case 1: - ret = subr (sp[0]); - break; - case 2: - ret = subr (sp[-1], sp[0]); - break; - case 3: - ret = subr (sp[-2], sp[-1], sp[0]); - break; - case 4: - ret = subr (sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 5: - ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 6: - ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 7: - ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 8: - ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 9: - ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - case 10: - ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); - break; - default: - abort (); - } - - NULLSTACK_FOR_NONLOCAL_EXIT (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - /* multiple values returned to continuation */ - ret = scm_struct_ref (ret, SCM_INUM0); - nvalues = scm_ilength (ret); - PUSH_LIST (ret, scm_is_null); - goto vm_return_values; - } - else - { - PUSH (ret); - goto vm_return; - } -} - -/* Instruction 58 used to be smob-call. */ - -VM_DEFINE_INSTRUCTION (59, foreign_call, "foreign-call", 1, -1, -1) -{ - SCM foreign, ret; - nargs = FETCH (); - POP (foreign); - - VM_HANDLE_INTERRUPTS; - SYNC_REGISTER (); - - ret = scm_i_foreign_call (foreign, sp - nargs + 1); - - NULLSTACK_FOR_NONLOCAL_EXIT (); - - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - /* multiple values returned to continuation */ - ret = scm_struct_ref (ret, SCM_INUM0); - nvalues = scm_ilength (ret); - PUSH_LIST (ret, scm_is_null); - goto vm_return_values; - } - else - { - PUSH (ret); - goto vm_return; - } -} - -VM_DEFINE_INSTRUCTION (60, continuation_call, "continuation-call", 0, -1, 0) -{ - SCM contregs; - POP (contregs); - - SYNC_ALL (); - scm_i_check_continuation (contregs); - vm_return_to_continuation (scm_i_contregs_vm (contregs), - scm_i_contregs_vm_cont (contregs), - sp - (fp - 1), fp); - scm_i_reinstate_continuation (contregs); - - /* no NEXT */ - abort (); -} - -VM_DEFINE_INSTRUCTION (61, partial_cont_call, "partial-cont-call", 0, -1, 0) -{ - SCM vmcont; - POP (vmcont); - SYNC_REGISTER (); - VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), - vm_error_continuation_not_rewindable (vmcont)); - vm_reinstate_partial_continuation (vm, vmcont, sp + 1 - fp, fp, - ¤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 f87236e16..5b3263993 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -603,8 +603,6 @@ vm_error_bad_wide_string_length (size_t len) -static SCM boot_continuation; - static SCM rtl_boot_continuation; static SCM vm_builtin_apply; static SCM vm_builtin_values; @@ -768,29 +766,22 @@ initialize_default_stack_size (void) vm_stack_size = size; } -#define VM_NAME vm_regular_engine #define RTL_VM_NAME rtl_vm_regular_engine #define FUNC_NAME "vm-regular-engine" #define VM_ENGINE SCM_VM_REGULAR_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef RTL_VM_NAME #undef FUNC_NAME #undef VM_ENGINE -#define VM_NAME vm_debug_engine #define RTL_VM_NAME rtl_vm_debug_engine #define FUNC_NAME "vm-debug-engine" #define VM_ENGINE SCM_VM_DEBUG_ENGINE #include "vm-engine.c" -#undef VM_NAME #undef RTL_VM_NAME #undef FUNC_NAME #undef VM_ENGINE -static const scm_t_vm_engine vm_engines[] = - { vm_regular_engine, vm_debug_engine }; - typedef SCM (*scm_t_rtl_vm_engine) (SCM vm, SCM program, SCM *argv, size_t nargs); static const scm_t_rtl_vm_engine rtl_vm_engines[] = @@ -879,10 +870,7 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) { struct scm_vm *vp = SCM_VM_DATA (vm); SCM_CHECK_STACK; - if (SCM_PROGRAM_P (program)) - return vm_engines[vp->engine](vm, program, argv, nargs); - else - return rtl_vm_engines[vp->engine](vm, program, argv, nargs); + return rtl_vm_engines[vp->engine](vm, program, argv, nargs); } /* Scheme interface */ @@ -1196,32 +1184,6 @@ SCM scm_load_compiled_with_vm (SCM file) } -static SCM -make_boot_program (void) -{ - struct scm_objcode *bp; - size_t bp_size; - SCM u8vec, ret; - - const scm_t_uint8 text[] = { - scm_op_make_int8_1, - scm_op_halt - }; - - bp_size = sizeof (struct scm_objcode) + sizeof (text); - bp = scm_gc_malloc_pointerless (bp_size, "boot-program"); - memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text)); - bp->len = sizeof(text); - bp->metalen = 0; - - u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size, SCM_BOOL_F); - ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED), - SCM_BOOL_F, SCM_BOOL_F); - SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT)); - - return ret; -} - void scm_init_vm_builtin_properties (void) { @@ -1263,8 +1225,6 @@ scm_bootstrap_vm (void) sym_regular = scm_from_latin1_symbol ("regular"); sym_debug = scm_from_latin1_symbol ("debug"); - boot_continuation = make_boot_program (); - rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code); SCM_SET_CELL_WORD_0 (rtl_boot_continuation, (SCM_CELL_WORD_0 (rtl_boot_continuation) diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm index ff1114727..4c2103391 100644 --- a/module/ice-9/session.scm +++ b/module/ice-9/session.scm @@ -522,8 +522,7 @@ The alist keys that are currently defined are `required', `optional', (rest . ,rest))))) ((procedure-source proc) => cadr) - ((or ((@ (system vm program) program?) proc) - ((@ (system vm program) rtl-program?) proc)) + (((@ (system vm program) rtl-program?) proc) ((@ (system vm program) program-arguments-alist) proc)) (else #f))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 22287f6d4..5a87cd99b 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -950,7 +950,7 @@ given `tree-il' element." (or (and (or (null? x) (pair? x)) (length x)) 0)) - (cond ((or (program? proc) (rtl-program? proc)) + (cond ((rtl-program? proc) (values (procedure-name proc) (map (lambda (a) (list (length (or (assq-ref a 'required) '())) diff --git a/module/statprof.scm b/module/statprof.scm index 36c53a585..bb6751b7b 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -217,7 +217,6 @@ (define (get-call-data proc) (let ((k (cond - ((program? proc) (program-objcode proc)) ((rtl-program? proc) (rtl-program-code proc)) (else proc)))) (or (hashv-ref procedure-data k) @@ -581,8 +580,6 @@ to @code{statprof-reset} is true." (lambda (a b) (cond ((eq? a b)) - ((and (program? a) (program? b)) - (eq? (program-objcode a) (program-objcode b))) ((and (rtl-program? a) (rtl-program? b)) (eq? (rtl-program-code a) (rtl-program-code b))) (else diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 251cd8966..2ca73648d 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -170,7 +170,8 @@ ;; Patches welcome! (define (frame->module frame) (let ((proc (frame-procedure frame))) - (if (program? proc) + (if #f + ;; FIXME! (let* ((mod (or (program-module proc) (current-module))) (mod* (make-module))) (module-use! mod* mod) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index e3b3352d5..ed042face 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -31,9 +31,7 @@ (define (frame-bindings frame) (let ((p (frame-procedure frame))) - (if (program? p) - (program-bindings-for-ip p (frame-instruction-pointer frame)) - '()))) + (program-bindings-for-ip p (frame-instruction-pointer frame)))) (define (frame-lookup-binding frame var) (let lp ((bindings (frame-bindings frame))) @@ -90,7 +88,7 @@ (cons (or (false-if-exception (procedure-name p)) p) (cond - ((and (or (program? p) (rtl-program? p)) + ((and (rtl-program? p) (program-arguments-alist p (frame-instruction-pointer frame))) ;; case 1 => (lambda (arguments) diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm index 81c6ab5b9..78d9db137 100644 --- a/module/system/vm/instruction.scm +++ b/module/system/vm/instruction.scm @@ -1,6 +1,6 @@ ;;; Guile VM instructions -;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2010, 2012, 2013 Free Software Foundation, Inc. ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -19,11 +19,7 @@ ;;; Code: (define-module (system vm instruction) - #:export (rtl-instruction-list - instruction-list - instruction? instruction-length - instruction-pops instruction-pushes - instruction->opcode opcode->instruction)) + #:export (rtl-instruction-list)) (load-extension (string-append "libguile-" (effective-version)) "scm_init_instructions") diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index f99df8091..243f43eee 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -25,8 +25,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #:export (make-program - make-rtl-program + #:export (make-rtl-program make-binding binding:name binding:boxed? binding:index binding:start binding:end @@ -35,7 +34,8 @@ source:line-for-user program-sources program-sources-pre-retire program-source - program-bindings program-bindings-by-index program-bindings-for-ip + program-bindings-for-ip + program-arities program-arity arity:start arity:end arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? @@ -43,10 +43,7 @@ program-arguments-alist program-arguments-alists program-lambda-list - program-meta - program-objcode program? program-objects rtl-program? rtl-program-code - program-module program-base program-free-variables program-num-free-variables program-free-variable-ref program-free-variable-set!)) @@ -96,29 +93,6 @@ (define (source:line-for-user source) (1+ (source:line source))) -;; FIXME: pull this definition from elsewhere. -(define *bytecode-header-len* 8) - -;; We could decompile the program to get this, but that seems like a -;; waste. -(define (bytecode-instruction-length bytecode ip) - (let* ((idx (+ ip *bytecode-header-len*)) - (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) - ;; 1+ for the instruction itself. - (1+ (cond - ((eq? inst 'load-program) - (+ (bytevector-u32-native-ref bytecode (+ idx 1)) - (bytevector-u32-native-ref bytecode (+ idx 5)))) - ((< (instruction-length inst) 0) - ;; variable length instruction -- the length is encoded in the - ;; instruction stream. - (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) - (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) - (bytevector-u8-ref bytecode (+ idx 3)))) - (else - ;; fixed length - (instruction-length inst)))))) - (define (source-for-addr addr) (and=> (find-source-for-addr addr) (lambda (source) @@ -129,16 +103,12 @@ (source-column source))))) (define (program-sources proc) - (cond - ((rtl-program? proc) - (map (lambda (source) - (cons* (- (source-post-pc source) (rtl-program-code proc)) - (source-file source) - (source-line source) - (source-column source))) - (find-program-sources (rtl-program-code proc)))) - (else - (%program-sources proc)))) + (map (lambda (source) + (cons* (- (source-post-pc source) (rtl-program-code proc)) + (source-file source) + (source-line source) + (source-column source))) + (find-program-sources (rtl-program-code proc)))) (define* (program-source proc ip #:optional (sources (program-sources proc))) (let lp ((source #f) (sources sources)) @@ -185,9 +155,8 @@ ;; returns list of list of bindings ;; (list-ref ret N) == bindings bound to the Nth local slot (define (program-bindings-by-index prog) - (cond ((rtl-program? prog) '()) - ((program-bindings prog) => collapse-locals) - (else '()))) + ;; FIXME! + '()) (define (program-bindings-for-ip prog ip) (let lp ((in (program-bindings-by-index prog)) (out '())) @@ -343,9 +312,6 @@ lists." (if arities (map arity-arguments-alist arities) (fallback)))) - ((program? prog) - (map (lambda (arity) (arity->arguments-alist prog arity)) - (or (program-arities prog) '()))) (else (error "expected a program" prog)))) (define (write-program prog port) |