diff options
author | Andy Wingo <wingo@pobox.com> | 2008-08-21 18:39:30 -0700 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-08-21 18:39:30 -0700 |
commit | 83495480e8e401d99158222f61d5c96fd2480e24 (patch) | |
tree | cdc006fdec9fda0909563b9daacf207e31265afa /libguile | |
parent | be52b55a3213c8f683d1007a542771daa3f9a06b (diff) | |
download | guile-83495480e8e401d99158222f61d5c96fd2480e24.tar.gz |
merge guile-vm into libguile itself
* ice-9/boot-9.scm: Only define load-compiled as #f if it's not already
defined, which won't normally be the case.
* libguile/guile-vm.c: Removed, there's no more guile-vm binary.
* libguile/frames.c: (with change frame? -> heap-frame?)
* libguile/frames.h:
* libguile/instructions.c:
* libguile/instructions.h:
* libguile/objcodes.c:
* libguile/objcodes.h:
* libguile/programs.c:
* libguile/programs.h:
* libguile/vm-bootstrap.h: (was bootstrap.h)
* libguile/vm-engine.c: (was vm_engine.c)
* libguile/vm-engine.h: (was vm_engine.h)
* libguile/vm-expand.h: (was vm_expand.h)
* libguile/vm-i-loader.c: (was vm_loader.c)
* libguile/vm-i-scheme.c: (was vm_scheme.c)
* libguile/vm-i-system.c: (was vm_system.c)
* libguile/vm.c:
* libguile/vm.h: These files moved here from src/, as guile-vm is now a
part of libguile.
* libguile/init.c: Bootstrap the VM. Yay!
* libguile/Makefile.am: The necessary chicanery here.
* module/system/vm/Makefile.am:
* module/system/vm/bootstrap.scm:
* module/system/vm/frame.scm:
* module/system/vm/instruction.scm:
* module/system/vm/objcode.scm:
* module/system/vm/program.scm:
* module/system/vm/vm.scm:
* pre-inst-guile-env.in: Add builddirs to the load path; add module/ to
the path in the empty-$GUILE_LOAD_PATH case as well.
* src/Makefile.am: Moved out everything except guilec and guile-disasm,
which probably should be moved to the scripts directory?
* testsuite/Makefile.am: Update to find guile-vm in the right place.
* module/system/vm/Makefile.am:
* module/system/vm/bootstrap.scm: Removed bootstrap.scm, scm_init_guile
handles the bootstrapping for us.
* module/system/vm/frame.scm:
* module/system/vm/instruction.scm:
* module/system/vm/objcode.scm:
* module/system/vm/program.scm:
* module/system/vm/vm.scm: Call the init functions in libguile; should
fix at some point to avoid the dlopen?
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 19 | ||||
-rw-r--r-- | libguile/frames.c | 197 | ||||
-rw-r--r-- | libguile/frames.h | 125 | ||||
-rw-r--r-- | libguile/init.c | 3 | ||||
-rw-r--r-- | libguile/instructions.c | 181 | ||||
-rw-r--r-- | libguile/instructions.h | 99 | ||||
-rw-r--r-- | libguile/objcodes.c | 301 | ||||
-rw-r--r-- | libguile/objcodes.h | 78 | ||||
-rw-r--r-- | libguile/programs.c | 258 | ||||
-rw-r--r-- | libguile/programs.h | 93 | ||||
-rw-r--r-- | libguile/vm-bootstrap.h | 53 | ||||
-rw-r--r-- | libguile/vm-engine.c | 206 | ||||
-rw-r--r-- | libguile/vm-engine.h | 487 | ||||
-rw-r--r-- | libguile/vm-expand.h | 103 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 229 | ||||
-rw-r--r-- | libguile/vm-i-scheme.c | 283 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 672 | ||||
-rw-r--r-- | libguile/vm.c | 680 | ||||
-rw-r--r-- | libguile/vm.h | 117 |
19 files changed, 4183 insertions, 1 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 74ed806dd..0f91cbc97 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -115,6 +115,9 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ ramap.c unif.c +# vm-related sources +libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c + libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \ $(libguile_la_CFLAGS) @@ -139,6 +142,9 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ strports.x struct.x symbols.x threads.x throw.x values.x \ variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x +# vm-related snarfs +DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x + EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ @@ -162,9 +168,14 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ 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: + grep '^VM_DEFINE' $< > $@ + BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \ version.h scmconfig.h \ - $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) + $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) EXTRA_libguile_la_SOURCES = _scm.h \ inet_aton.c memmove.c putenv.c strerror.c \ @@ -192,6 +203,9 @@ noinst_HEADERS = convert.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ private-gc.h private-options.h +# vm instructions +noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c + libguile_la_DEPENDENCIES = @LIBLOBJS@ libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined @@ -219,6 +233,9 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ pthread-threads.h null-threads.h throw.h unif.h values.h \ variable.h vectors.h vports.h weaks.h +modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \ + programs.h vm.h vm-engine.h vm-expand.h + nodist_modinclude_HEADERS = version.h scmconfig.h bin_SCRIPTS = guile-snarf diff --git a/libguile/frames.c b/libguile/frames.c new file mode 100644 index 000000000..c4f2f275d --- /dev/null +++ b/libguile/frames.c @@ -0,0 +1,197 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "vm-bootstrap.h" +#include "frames.h" + + +scm_t_bits scm_tc16_heap_frame; + +SCM +scm_c_make_heap_frame (SCM *fp) +{ + SCM frame; + SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp); + SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp); + size_t size = sizeof (SCM) * (upper - lower + 1); + SCM *p = scm_gc_malloc (size, "frame"); + + SCM_NEWSMOB (frame, scm_tc16_heap_frame, p); + p[0] = frame; /* self link */ + memcpy (p + 1, lower, size - sizeof (SCM)); + + return frame; +} + +static SCM +heap_frame_mark (SCM obj) +{ + SCM *sp; + SCM *fp = SCM_HEAP_FRAME_POINTER (obj); + SCM *limit = &SCM_FRAME_HEAP_LINK (fp); + + for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++) + if (SCM_NIMP (*sp)) + scm_gc_mark (*sp); + + return SCM_BOOL_F; +} + +static scm_sizet +heap_frame_free (SCM obj) +{ + SCM *fp = SCM_HEAP_FRAME_POINTER (obj); + SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp); + SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp); + size_t size = sizeof (SCM) * (upper - lower + 1); + + scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame"); + + return 0; +} + +/* Scheme interface */ + +SCM_DEFINE (scm_heap_frame_p, "heap-frame?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_heap_frame_p +{ + return SCM_BOOL (SCM_HEAP_FRAME_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_program +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, + (SCM frame, SCM index), + "") +#define FUNC_NAME s_scm_frame_local_ref +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */ + return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), + SCM_I_INUM (index)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, + (SCM frame, SCM index, SCM val), + "") +#define FUNC_NAME s_scm_frame_local_set_x +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */ + SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame), + SCM_I_INUM (index)) = val; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_return_address +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + return scm_from_ulong ((unsigned long) + (SCM_FRAME_RETURN_ADDRESS + (SCM_HEAP_FRAME_POINTER (frame)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_dynamic_link +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_external_link +{ + SCM_VALIDATE_HEAP_FRAME (1, frame); + return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame)); +} +#undef FUNC_NAME + + +void +scm_bootstrap_frames (void) +{ + scm_tc16_heap_frame = scm_make_smob_type ("frame", 0); + scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark); + scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free); +} + +void +scm_init_frames (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "frames.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/frames.h b/libguile/frames.h new file mode 100644 index 000000000..53fc4e858 --- /dev/null +++ b/libguile/frames.h @@ -0,0 +1,125 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_FRAMES_H_ +#define _SCM_FRAMES_H_ + +#include <libguile.h> +#include "programs.h" + + +/* + * VM frames + */ + +/* VM Frame Layout + --------------- + + | | <- fp + bp->nargs + bp->nlocs + 4 + +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp) + | Return address | + | Dynamic link | + | Heap link | + | External link | <- fp + bp->nargs + bp->nlocs + | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp) + | Local variable 0 | <- fp + bp->nargs + | Argument 1 | + | Argument 0 | <- fp + | Program | <- fp - 1 + +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp) + | | + + As can be inferred from this drawing, it is assumed that + `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are + assumed to be as long as SCM objects. */ + +#define SCM_FRAME_DATA_ADDRESS(fp) \ + (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \ + + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs) +#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4) +#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1) + +#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x)) +#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x)) + +#define SCM_FRAME_RETURN_ADDRESS(fp) \ + (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])) +#define SCM_FRAME_DYNAMIC_LINK(fp) \ + (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])) +#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ + ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl); +#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1]) +#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0]) +#define SCM_FRAME_VARIABLE(fp,i) fp[i] +#define SCM_FRAME_PROGRAM(fp) fp[-1] + + +/* + * Heap frames + */ + +extern scm_t_bits scm_tc16_heap_frame; + +#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x) +#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f)) +#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0) +#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2) +#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P) + +extern SCM scm_heap_frame_p (SCM obj); +extern SCM scm_frame_program (SCM frame); +extern SCM scm_frame_local_ref (SCM frame, SCM index); +extern SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val); +extern SCM scm_frame_return_address (SCM frame); +extern SCM scm_frame_dynamic_link (SCM frame); +extern SCM scm_frame_external_link (SCM frame); + +extern SCM scm_c_make_heap_frame (SCM *fp); +extern void scm_bootstrap_frames (void); +extern void scm_init_frames (void); + +#endif /* _SCM_FRAMES_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/init.c b/libguile/init.c index 25cff62a5..cdd756894 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -118,6 +118,7 @@ #include "libguile/variable.h" #include "libguile/vectors.h" #include "libguile/version.h" +#include "libguile/vm-bootstrap.h" #include "libguile/vports.h" #include "libguile/weaks.h" #include "libguile/guardians.h" @@ -572,6 +573,8 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_rw (); scm_init_extensions (); + scm_bootstrap_vm (); + atexit (cleanup_for_exit); scm_load_startup_files (); } diff --git a/libguile/instructions.c b/libguile/instructions.c new file mode 100644 index 000000000..89b6c774b --- /dev/null +++ b/libguile/instructions.c @@ -0,0 +1,181 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "vm-bootstrap.h" +#include "instructions.h" + +struct scm_instruction scm_instruction_table[] = { +#define VM_INSTRUCTION_TO_TABLE 1 +#include "vm-expand.h" +#include "vm-i-system.i" +#include "vm-i-scheme.i" +#include "vm-i-loader.i" +#undef VM_INSTRUCTION_TO_TABLE + {scm_op_last} +}; + +/* C interface */ + +struct scm_instruction * +scm_lookup_instruction (SCM name) +{ + struct scm_instruction *ip; + char *symbol; + + if (SCM_SYMBOLP (name)) + for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++) + { + symbol = scm_to_locale_string (scm_symbol_to_string (name)); + if ((symbol) && (strcmp (ip->name, symbol) == 0)) + { + free (symbol); + return ip; + } + + if (symbol) + free (symbol); + } + + return 0; +} + +/* Scheme interface */ + +SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_instruction_list +{ + SCM list = SCM_EOL; + struct scm_instruction *ip; + for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++) + list = scm_cons (scm_from_locale_symbol (ip->name), list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_instruction_p +{ + return SCM_BOOL (SCM_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_length +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_I_MAKINUM (SCM_INSTRUCTION_LENGTH (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pops +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_I_MAKINUM (SCM_INSTRUCTION_POPS (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pushes +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_I_MAKINUM (SCM_INSTRUCTION_PUSHES (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_to_opcode +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_I_MAKINUM (SCM_INSTRUCTION_OPCODE (inst)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, + (SCM op), + "") +#define FUNC_NAME s_scm_opcode_to_instruction +{ + int i; + SCM_MAKE_VALIDATE (1, op, I_INUMP); + i = SCM_I_INUM (op); + SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last); + return scm_from_locale_symbol (scm_instruction_table[i].name); +} +#undef FUNC_NAME + +void +scm_bootstrap_instructions (void) +{ +} + +void +scm_init_instructions (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "instructions.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/instructions.h b/libguile/instructions.h new file mode 100644 index 000000000..1a965daf9 --- /dev/null +++ b/libguile/instructions.h @@ -0,0 +1,99 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_INSTRUCTIONS_H_ +#define _SCM_INSTRUCTIONS_H_ + +#include <libguile.h> + +enum scm_opcode { +#define VM_INSTRUCTION_TO_OPCODE 1 +#include "vm-expand.h" +#include "vm-i-system.i" +#include "vm-i-scheme.i" +#include "vm-i-loader.i" +#undef VM_INSTRUCTION_TO_OPCODE + scm_op_last +}; + +struct scm_instruction { + enum scm_opcode opcode; /* opcode */ + const char *name; /* instruction name */ + signed char len; /* Instruction length. This may be -1 for + the loader (see the `VM_LOADER' + macro). */ + signed char npop; /* The number of values popped. This may be + -1 for insns like `call' which can take + any number of arguments. */ + char npush; /* the number of values pushed */ +}; + +#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x)) +#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode) +#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name) +#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len) +#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop) +#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush) +#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P) + +#define SCM_INSTRUCTION(i) (&scm_instruction_table[i]) + +extern struct scm_instruction scm_instruction_table[]; +extern struct scm_instruction *scm_lookup_instruction (SCM name); + +extern SCM scm_instruction_list (void); +extern SCM scm_instruction_p (SCM obj); +extern SCM scm_instruction_length (SCM inst); +extern SCM scm_instruction_pops (SCM inst); +extern SCM scm_instruction_pushes (SCM inst); +extern SCM scm_instruction_to_opcode (SCM inst); +extern SCM scm_opcode_to_instruction (SCM op); + +extern void scm_bootstrap_instructions (void); +extern void scm_init_instructions (void); + +#endif /* _SCM_INSTRUCTIONS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/objcodes.c b/libguile/objcodes.c new file mode 100644 index 000000000..6891e8a6a --- /dev/null +++ b/libguile/objcodes.c @@ -0,0 +1,301 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include <fcntl.h> +#include <unistd.h> +#include <sys/mman.h> +#include <sys/stat.h> +#include <sys/types.h> +#include <assert.h> + +#include "vm-bootstrap.h" +#include "programs.h" +#include "objcodes.h" + +#define OBJCODE_COOKIE "GOOF-0.5" + + +/* + * Objcode type + */ + +scm_t_bits scm_tc16_objcode; + +static SCM +make_objcode (size_t size) +#define FUNC_NAME "make_objcode" +{ + struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode), + "objcode"); + p->size = size; + p->base = scm_gc_malloc (size, "objcode-base"); + p->fd = -1; + SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); +} +#undef FUNC_NAME + +static SCM +make_objcode_by_mmap (int fd) +#define FUNC_NAME "make_objcode_by_mmap" +{ + int ret; + char *addr; + struct stat st; + struct scm_objcode *p; + + ret = fstat (fd, &st); + if (ret < 0) + SCM_SYSERROR; + + if (st.st_size <= strlen (OBJCODE_COOKIE)) + scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", + SCM_LIST1 (SCM_I_MAKINUM (st.st_size))); + + addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0); + if (addr == MAP_FAILED) + SCM_SYSERROR; + + if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE))) + SCM_SYSERROR; + + p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode"); + p->size = st.st_size; + p->base = addr; + p->fd = fd; + SCM_RETURN_NEWSMOB (scm_tc16_objcode, p); +} +#undef FUNC_NAME + +static scm_sizet +objcode_free (SCM obj) +#define FUNC_NAME "objcode_free" +{ + size_t size = sizeof (struct scm_objcode); + struct scm_objcode *p = SCM_OBJCODE_DATA (obj); + + if (p->fd >= 0) + { + int rv; + rv = munmap (p->base, p->size); + if (rv < 0) SCM_SYSERROR; + rv = close (p->fd); + if (rv < 0) SCM_SYSERROR; + } + else + scm_gc_free (p->base, p->size, "objcode-base"); + + scm_gc_free (p, size, "objcode"); + + return 0; +} +#undef FUNC_NAME + + +/* + * Scheme interface + */ + +#if 0 +SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0, + (SCM car, SCM cdr), + "This is a stupid test to see how cells work. (Ludo)") +{ + static SCM room[512]; + static SCM *where = &room[0]; + SCM the_pair; + size_t incr; + + if ((scm_t_bits)where & 6) + { + /* Align the cell pointer so that Guile considers it as a + non-immediate object (see tags.h). */ + incr = (scm_t_bits)where & 6; + incr = (~incr) & 7; + where += incr; + } + + printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where); + where[0] = car; + where[1] = cdr; + + the_pair = PTR2SCM (where); + /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a + "mark bitmap" at the end of a supposed cell segment which doesn't + exist. */ + + return (the_pair); +} +#endif + +SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_objcode_p +{ + return SCM_BOOL (SCM_OBJCODE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0, + (SCM bytecode, SCM nlocs, SCM nexts), + "") +#define FUNC_NAME s_scm_bytecode_to_objcode +{ + size_t size; + ssize_t increment; + scm_t_array_handle handle; + char *base; + const scm_t_uint8 *c_bytecode; + SCM objcode; + + if (scm_u8vector_p (bytecode) != SCM_BOOL_T) + scm_wrong_type_arg (FUNC_NAME, 1, bytecode); + SCM_VALIDATE_NUMBER (2, nlocs); + SCM_VALIDATE_NUMBER (3, nexts); + + c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); + assert (increment == 1); + + /* Account for the 10 byte-long header. */ + size += 10; + objcode = make_objcode (size); + base = SCM_OBJCODE_BASE (objcode); + + memcpy (base, OBJCODE_COOKIE, 8); + base[8] = scm_to_uint8 (nlocs); + base[9] = scm_to_uint8 (nexts); + + memcpy (base + 10, c_bytecode, size - 10); + + scm_array_handle_release (&handle); + + return objcode; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, + (SCM file), + "") +#define FUNC_NAME s_scm_load_objcode +{ + int fd; + char *c_file; + + SCM_VALIDATE_STRING (1, file); + + c_file = scm_to_locale_string (file); + fd = open (c_file, O_RDONLY); + free (c_file); + if (fd < 0) SCM_SYSERROR; + + return make_objcode_by_mmap (fd); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_to_u8vector +{ + scm_t_uint8 *u8vector; + size_t size; + + SCM_VALIDATE_OBJCODE (1, objcode); + + size = SCM_OBJCODE_SIZE (objcode); + /* FIXME: Is `gc_malloc' ok here? */ + u8vector = scm_gc_malloc (size, "objcode-u8vector"); + memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size); + + return scm_take_u8vector (u8vector, size); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_to_program +{ + SCM prog; + size_t size; + char *base; + struct scm_program *p; + + SCM_VALIDATE_OBJCODE (1, objcode); + + base = SCM_OBJCODE_BASE (objcode); + size = SCM_OBJCODE_SIZE (objcode); + prog = scm_c_make_program (base + 10, size - 10, objcode); + p = SCM_PROGRAM_DATA (prog); + p->nlocs = base[8]; + p->nexts = base[9]; + return prog; +} +#undef FUNC_NAME + + +void +scm_bootstrap_objcodes (void) +{ + scm_tc16_objcode = scm_make_smob_type ("objcode", 0); + scm_set_smob_free (scm_tc16_objcode, objcode_free); +} + +void +scm_init_objcodes (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "objcodes.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/objcodes.h b/libguile/objcodes.h new file mode 100644 index 000000000..2cedefa98 --- /dev/null +++ b/libguile/objcodes.h @@ -0,0 +1,78 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_OBJCODES_H_ +#define _SCM_OBJCODES_H_ + +#include <libguile.h> + +struct scm_objcode { + size_t size; /* objcode size */ + char *base; /* objcode base address */ + int fd; /* file descriptor when mmap'ed */ +}; + +extern scm_t_bits scm_tc16_objcode; + +#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) +#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) +#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P) + +#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size) +#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base) +#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd) + +extern SCM scm_load_objcode (SCM file); +extern SCM scm_objcode_to_program (SCM objcode); +extern SCM scm_objcode_p (SCM obj); +extern SCM scm_bytecode_to_objcode (SCM bytecode, SCM nlocs, SCM nexts); +extern SCM scm_objcode_to_u8vector (SCM objcode); + +extern void scm_bootstrap_objcodes (void); +extern void scm_init_objcodes (void); + +#endif /* _SCM_OBJCODES_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/programs.c b/libguile/programs.c new file mode 100644 index 000000000..436e2b863 --- /dev/null +++ b/libguile/programs.c @@ -0,0 +1,258 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "vm-bootstrap.h" +#include "instructions.h" +#include "programs.h" +#include "vm.h" + + +scm_t_bits scm_tc16_program; + +static SCM zero_vector; + +SCM +scm_c_make_program (void *addr, size_t size, SCM holder) +#define FUNC_NAME "scm_c_make_program" +{ + struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program), + "program"); + p->size = size; + p->nargs = 0; + p->nrest = 0; + p->nlocs = 0; + p->nexts = 0; + p->meta = SCM_BOOL_F; + p->objs = zero_vector; + p->external = SCM_EOL; + p->holder = holder; + + /* If nobody holds bytecode's address, then allocate a new memory */ + if (SCM_FALSEP (holder)) + { + p->base = scm_gc_malloc (size, "program-base"); + memcpy (p->base, addr, size); + } + else + p->base = addr; + + SCM_RETURN_NEWSMOB (scm_tc16_program, p); +} +#undef FUNC_NAME + +SCM +scm_c_make_closure (SCM program, SCM external) +{ + SCM prog = scm_c_make_program (0, 0, program); + *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program); + SCM_PROGRAM_DATA (prog)->external = external; + return prog; +} + +static SCM +program_mark (SCM obj) +{ + struct scm_program *p = SCM_PROGRAM_DATA (obj); + scm_gc_mark (p->meta); + scm_gc_mark (p->objs); + scm_gc_mark (p->external); + return p->holder; +} + +static scm_sizet +program_free (SCM obj) +{ + struct scm_program *p = SCM_PROGRAM_DATA (obj); + scm_sizet size = (sizeof (struct scm_program)); + + if (SCM_FALSEP (p->holder)) + scm_gc_free (p->base, p->size, "program-base"); + + scm_gc_free (p, size, "program"); + + return 0; +} + +static SCM +program_apply (SCM program, SCM args) +{ + return scm_vm_apply (scm_the_vm (), program, args); +} + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_program_p +{ + return SCM_BOOL (SCM_PROGRAM_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_base +{ + SCM_VALIDATE_PROGRAM (1, program); + + return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_arity +{ + struct scm_program *p; + + SCM_VALIDATE_PROGRAM (1, program); + + p = SCM_PROGRAM_DATA (program); + return SCM_LIST4 (SCM_I_MAKINUM (p->nargs), + SCM_I_MAKINUM (p->nrest), + SCM_I_MAKINUM (p->nlocs), + SCM_I_MAKINUM (p->nexts)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_meta +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_DATA (program)->meta; +} +#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_DATA (program)->objs; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_external +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_DATA (program)->external; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0, + (SCM program, SCM external), + "Modify the list of closure variables of @var{program} (for " + "debugging purposes).") +#define FUNC_NAME s_scm_program_external_set_x +{ + SCM_VALIDATE_PROGRAM (1, program); + SCM_VALIDATE_LIST (2, external); + SCM_PROGRAM_DATA (program)->external = external; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0, + (SCM program), + "Return a u8vector containing @var{program}'s bytecode.") +#define FUNC_NAME s_scm_program_bytecode +{ + size_t size; + scm_t_uint8 *c_bytecode; + + SCM_VALIDATE_PROGRAM (1, program); + + size = SCM_PROGRAM_DATA (program)->size; + c_bytecode = malloc (size); + if (!c_bytecode) + return SCM_BOOL_F; + + memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size); + + return scm_take_u8vector (c_bytecode, size); +} +#undef FUNC_NAME + + + +void +scm_bootstrap_programs (void) +{ + zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F)); + + scm_tc16_program = scm_make_smob_type ("program", 0); + scm_set_smob_mark (scm_tc16_program, program_mark); + scm_set_smob_free (scm_tc16_program, program_free); + scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1); +} + +void +scm_init_programs (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "programs.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/programs.h b/libguile/programs.h new file mode 100644 index 000000000..04f2d459d --- /dev/null +++ b/libguile/programs.h @@ -0,0 +1,93 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_PROGRAMS_H_ +#define _SCM_PROGRAMS_H_ + +#include <libguile.h> + +/* + * Programs + */ + +typedef unsigned char scm_byte_t; + +struct scm_program { + size_t size; /* the size of the program */ + unsigned char nargs; /* the number of arguments */ + unsigned char nrest; /* the number of rest argument (0 or 1) */ + unsigned char nlocs; /* the number of local variables */ + unsigned char nexts; /* the number of external variables */ + scm_byte_t *base; /* program base address */ + SCM meta; /* meta data */ + SCM objs; /* constant objects */ + SCM external; /* external environment */ + SCM holder; /* the owner of bytecode */ +}; + +extern scm_t_bits scm_tc16_program; + +#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x)) +#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x)) +#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) + +extern SCM scm_c_make_program (void *addr, size_t size, SCM holder); +extern SCM scm_c_make_closure (SCM program, SCM external); + +extern SCM scm_program_p (SCM obj); +extern SCM scm_program_base (SCM program); +extern SCM scm_program_arity (SCM program); +extern SCM scm_program_meta (SCM program); +extern SCM scm_program_objects (SCM program); +extern SCM scm_program_external (SCM program); +extern SCM scm_program_external_set_x (SCM program, SCM external); +extern SCM scm_program_bytecode (SCM program); + +extern void scm_bootstrap_programs (void); +extern void scm_init_programs (void); + +#endif /* _SCM_PROGRAMS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h new file mode 100644 index 000000000..beecf0fc2 --- /dev/null +++ b/libguile/vm-bootstrap.h @@ -0,0 +1,53 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_VM_BOOTSTRAP_H_ +#define _SCM_VM_BOOTSTRAP_H_ + +extern void scm_bootstrap_vm (void); + +#endif /* _SCM_VM_BOOTSTRAP_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c new file mode 100644 index 000000000..def7e807b --- /dev/null +++ b/libguile/vm-engine.c @@ -0,0 +1,206 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm.c twice */ + +#include "vm-engine.h" + + +static SCM +vm_run (SCM vm, SCM program, SCM args) +#define FUNC_NAME "vm-engine" +{ + /* VM registers */ + register scm_byte_t *ip IP_REG; /* instruction pointer */ + register SCM *sp SP_REG; /* stack pointer */ + register SCM *fp FP_REG; /* frame pointer */ + + /* Cache variables */ + struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */ + struct scm_program *bp = NULL; /* program base pointer */ + SCM external = SCM_EOL; /* external environment */ + SCM *objects = NULL; /* constant objects */ + scm_t_array_handle objects_handle; /* handle of the OBJECTS array */ + size_t object_count; /* length of OBJECTS */ + SCM *stack_base = vp->stack_base; /* stack base address */ + SCM *stack_limit = vp->stack_limit; /* stack limit address */ + + /* Internal variables */ + int nargs = 0; + long start_time = scm_c_get_internal_run_time (); + // SCM dynwinds = SCM_EOL; + SCM err_msg; + SCM err_args; +#if VM_USE_HOOKS + SCM hook_args = SCM_LIST1 (vm); +#endif + struct vm_unwind_data wind_data; + + /* dynwind ended in the halt instruction */ + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + wind_data.vp = vp; + wind_data.sp = vp->sp; + wind_data.fp = vp->fp; + wind_data.this_frame = vp->this_frame; + scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0); + + +#ifdef HAVE_LABELS_AS_VALUES + /* Jump table */ + static void *jump_table[] = { +#define VM_INSTRUCTION_TO_LABEL 1 +#include "vm-expand.h" +#include "vm-i-system.i" +#include "vm-i-scheme.i" +#include "vm-i-loader.i" +#undef VM_INSTRUCTION_TO_LABEL + }; +#endif + + /* Initialization */ + { + SCM prog = program; + + /* Boot program */ + scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt}; + bytes[1] = scm_ilength (args); /* FIXME: argument overflow */ + program = scm_c_make_program (bytes, 3, SCM_BOOL_F); + + /* Initial frame */ + CACHE_REGISTER (); + CACHE_PROGRAM (); + PUSH (program); + NEW_FRAME (); + + /* Initial arguments */ + PUSH (prog); + for (; !SCM_NULLP (args); args = SCM_CDR (args)) + PUSH (SCM_CAR (args)); + } + + /* Let's go! */ + BOOT_HOOK (); + +#ifndef HAVE_LABELS_AS_VALUES + vm_start: + switch (*ip++) { +#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 + } +#endif + + /* Errors */ + { + vm_error_unbound: + err_msg = scm_from_locale_string ("VM: Unbound variable: ~A"); + goto vm_error; + + vm_error_wrong_type_arg: + err_msg = scm_from_locale_string ("VM: Wrong type argument"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_wrong_num_args: + err_msg = scm_from_locale_string ("VM: Wrong number of arguments"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_wrong_type_apply: + err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S " + "[IP offset: ~a]"); + err_args = SCM_LIST2 (program, + SCM_I_MAKINUM (ip - bp->base)); + goto vm_error; + + vm_error_stack_overflow: + err_msg = scm_from_locale_string ("VM: Stack overflow"); + err_args = SCM_EOL; + goto vm_error; + + vm_error_stack_underflow: + err_msg = scm_from_locale_string ("VM: Stack underflow"); + err_args = SCM_EOL; + goto vm_error; + +#if VM_CHECK_IP + vm_error_invalid_address: + err_msg = scm_from_locale_string ("VM: Invalid program address"); + err_args = SCM_EOL; + goto vm_error; +#endif + +#if VM_CHECK_EXTERNAL + vm_error_external: + err_msg = scm_from_locale_string ("VM: Invalid external access"); + err_args = SCM_EOL; + goto vm_error; +#endif + +#if VM_CHECK_OBJECT + vm_error_object: + err_msg = scm_from_locale_string ("VM: Invalid object table access"); + err_args = SCM_EOL; + goto vm_error; +#endif + + vm_error: + SYNC_ALL (); + if (objects) + scm_array_handle_release (&objects_handle); + + scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1); + } + + abort (); /* never reached */ +} +#undef FUNC_NAME + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h new file mode 100644 index 000000000..2026e3cdf --- /dev/null +++ b/libguile/vm-engine.h @@ -0,0 +1,487 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + +/* + * Options + */ + +#define VM_USE_HOOKS 1 /* Various hooks */ +#define VM_USE_CLOCK 1 /* Bogoclock */ +#define VM_CHECK_EXTERNAL 1 /* Check external link */ +#define VM_CHECK_OBJECT 1 /* Check object table */ + + +/* + * Registers + */ + +/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ] + + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, I have hand-assigned hardware registers for several architectures. +*/ + +#ifdef __GNUC__ +#ifdef __mips__ +#define IP_REG asm("$16") +#define SP_REG asm("$17") +#define FP_REG asm("$18") +#endif +#ifdef __sparc__ +#define IP_REG asm("%l0") +#define SP_REG asm("%l1") +#define FP_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define IP_REG asm("r9") +#define SP_REG asm("r10") +#define FP_REG asm("r11") +#else +#define IP_REG asm("$9") +#define SP_REG asm("$10") +#define FP_REG asm("$11") +#endif +#endif +#ifdef __i386__ +#define IP_REG asm("%esi") +#define SP_REG asm("%edi") +#define FP_REG +#endif +#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#define IP_REG asm("26") +#define SP_REG asm("27") +#define FP_REG asm("28") +#endif +#ifdef __hppa__ +#define IP_REG asm("%r18") +#define SP_REG asm("%r17") +#define FP_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define IP_REG asm("a5") +#define SP_REG asm("a4") +#define FP_REG +#endif +#ifdef __arm__ +#define IP_REG asm("r9") +#define SP_REG asm("r8") +#define FP_REG asm("r7") +#endif +#endif + +#ifndef IP_REG +#define IP_REG +#endif +#ifndef SP_REG +#define SP_REG +#endif +#ifndef FP_REG +#define FP_REG +#endif + + +/* + * Cache/Sync + */ + +#define CACHE_REGISTER() \ +{ \ + ip = vp->ip; \ + sp = vp->sp; \ + fp = vp->fp; \ +} + +#define SYNC_REGISTER() \ +{ \ + vp->ip = ip; \ + vp->sp = sp; \ + vp->fp = fp; \ +} + +#ifdef IP_PARANOIA +#define CHECK_IP() \ + do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0) +#else +#define CHECK_IP() +#endif + +/* Get a local copy of the program's "object table" (i.e. the vector of + external bindings that are referenced by the program), initialized by + `load-program'. */ +/* XXX: We could instead use the "simple vector macros", thus not having to + call `scm_vector_writable_elements ()' and the likes. */ +#define CACHE_PROGRAM() \ +{ \ + ssize_t _vincr; \ + \ + if (bp != SCM_PROGRAM_DATA (program)) { \ + bp = SCM_PROGRAM_DATA (program); \ + /* Was: objects = SCM_VELTS (bp->objs); */ \ + \ + if (objects) \ + scm_array_handle_release (&objects_handle); \ + \ + objects = scm_vector_writable_elements (bp->objs, &objects_handle, \ + &object_count, &_vincr); \ + } \ +} + +#define SYNC_BEFORE_GC() \ +{ \ + SYNC_REGISTER (); \ +} + +#define SYNC_ALL() \ +{ \ + SYNC_REGISTER (); \ +} + + +/* + * Error check + */ + +#undef CHECK_EXTERNAL +#if VM_CHECK_EXTERNAL +#define CHECK_EXTERNAL(e) \ + do { if (!SCM_CONSP (e)) goto vm_error_external; } while (0) +#else +#define CHECK_EXTERNAL(e) +#endif + +/* Accesses to a program's object table. */ +#if VM_CHECK_OBJECT +#define CHECK_OBJECT(_num) \ + do { if ((_num) >= object_count) goto vm_error_object; } while (0) +#else +#define CHECK_OBJECT(_num) +#endif + + +/* + * Hooks + */ + +#undef RUN_HOOK +#if VM_USE_HOOKS +#define RUN_HOOK(h) \ +{ \ + if (!SCM_FALSEP (vp->hooks[h])) \ + { \ + SYNC_REGISTER (); \ + vm_heapify_frames (vm); \ + scm_c_run_hook (vp->hooks[h], hook_args); \ + CACHE_REGISTER (); \ + } \ +} +#else +#define RUN_HOOK(h) +#endif + +#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK) +#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK) +#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK) +#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK) +#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK) +#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK) +#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK) +#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK) + + +/* + * Stack operation + */ + +#define CHECK_OVERFLOW() \ + if (sp > stack_limit) \ + goto vm_error_stack_overflow + +#define CHECK_UNDERFLOW() \ + if (sp < stack_base) \ + goto vm_error_stack_underflow; + +#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) +#define DROP() do { sp--; CHECK_UNDERFLOW (); } while (0) +#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); } while (0) +#define POP(x) do { x = *sp; DROP (); } while (0) + +/* A fast CONS. This has to be fast since its used, for instance, by + POP_LIST when fetching a function's argument list. Note: `scm_cell' is an + inlined function in Guile 1.7. Unfortunately, it calls + `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the + heap. XXX */ +#define CONS(x,y,z) \ +{ \ + SYNC_BEFORE_GC (); \ + x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \ +} + +/* 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; \ + sp -= n; \ + for (i = n; i; i--) \ + CONS (l, sp[i], l); \ + PUSH (l); \ +} while (0) + + +/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to + allocate cells on the stack. This is a significant improvement for + programs which call a lot of procedures, since the procedure call + mechanism uses POP_LIST which normally uses `scm_cons'. + + What it does is that it creates a list whose cells are allocated on the + VM's stack instead of being allocated on the heap via `scm_cell'. This is + much faster. However, if the callee does something like: + + (lambda (. args) + (set! the-args args)) + + then terrible things may happen since the list of arguments may be + overwritten later on. */ + + +/* Awful hack that aligns PTR so that it can be considered as a non-immediate + value by Guile. */ +#define ALIGN_AS_NON_IMMEDIATE(_ptr) \ +{ \ + if ((scm_t_bits)(_ptr) & 6) \ + { \ + size_t _incr; \ + \ + _incr = (scm_t_bits)(_ptr) & 6; \ + _incr = (~_incr) & 7; \ + (_ptr) += _incr; \ + } \ +} + +#define POP_LIST_ON_STACK(n) \ +do \ +{ \ + int i; \ + if (n == 0) \ + { \ + sp -= n; \ + PUSH (SCM_EOL); \ + } \ + else \ + { \ + SCM *list_head, *list; \ + \ + list_head = sp + 1; \ + ALIGN_AS_NON_IMMEDIATE (list_head); \ + list = list_head; \ + \ + sp -= n; \ + for (i = 1; i <= n; i++) \ + { \ + /* The cell's car and cdr. */ \ + *(list) = sp[i]; \ + *(list + 1) = PTR2SCM (list + 2); \ + list += 2; \ + } \ + \ + /* The last pair's cdr is '(). */ \ + list--; \ + *list = SCM_EOL; \ + /* Push the SCM object that points */ \ + /* to the first cell. */ \ + PUSH (PTR2SCM (list_head)); \ + } \ +} \ +while (0) + +/* end of the experiment */ + + +#define POP_LIST_MARK() \ +do { \ + SCM o; \ + SCM l = SCM_EOL; \ + POP (o); \ + while (!SCM_UNBNDP (o)) \ + { \ + CONS (l, o, l); \ + POP (o); \ + } \ + PUSH (l); \ +} while (0) + + +/* + * Instruction operation + */ + +#define FETCH() (*ip++) +#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0) + +#undef CLOCK +#if VM_USE_CLOCK +#define CLOCK(n) vp->clock += n +#else +#define CLOCK(n) +#endif + +#undef NEXT_JUMP +#ifdef HAVE_LABELS_AS_VALUES +#define NEXT_JUMP() goto *jump_table[FETCH ()] +#else +#define NEXT_JUMP() goto vm_start +#endif + +#define NEXT \ +{ \ + CLOCK (1); \ + NEXT_HOOK (); \ + NEXT_JUMP (); \ +} + + +/* + * Stack frame + */ + +#define INIT_ARGS() \ +{ \ + if (bp->nrest) \ + { \ + int n = nargs - (bp->nargs - 1); \ + if (n < 0) \ + goto vm_error_wrong_num_args; \ + POP_LIST (n); \ + } \ + else \ + { \ + if (nargs != bp->nargs) \ + goto vm_error_wrong_num_args; \ + } \ +} + +/* See frames.h for the layout of stack frames */ + +#define NEW_FRAME() \ +{ \ + int i; \ + SCM ra = SCM_PACK (ip); \ + SCM dl = SCM_PACK (fp); \ + SCM *p = sp + 1; \ + SCM *q = p + bp->nlocs; \ + \ + /* New pointers */ \ + ip = bp->base; \ + fp = p - bp->nargs; \ + sp = q + 3; \ + CHECK_OVERFLOW (); \ + \ + /* Init local variables */ \ + for (; p < q; p++) \ + *p = SCM_UNDEFINED; \ + \ + /* Create external variables */ \ + external = bp->external; \ + for (i = 0; i < bp->nexts; i++) \ + CONS (external, SCM_UNDEFINED, external); \ + \ + /* Set frame data */ \ + p[3] = ra; \ + p[2] = dl; \ + p[1] = SCM_BOOL_F; \ + p[0] = external; \ + stack_base = p + 3; \ +} + +#define FREE_FRAME() \ +{ \ + SCM *last_sp = sp; \ + SCM *last_fp = fp; \ + SCM *p = fp + bp->nargs + bp->nlocs; \ + \ + /* Restore pointers */ \ + ip = SCM_FRAME_BYTE_CAST (p[3]); \ + fp = SCM_FRAME_STACK_CAST (p[2]); \ + \ + if (!SCM_FALSEP (p[1])) \ + { \ + /* Unlink the heap stack */ \ + vp->this_frame = p[1]; \ + } \ + else \ + { \ + /* Move stack items */ \ + p += 4; \ + sp = SCM_FRAME_LOWER_ADDRESS (last_fp); \ + while (p <= last_sp) \ + *sp++ = *p++; \ + sp--; \ + } \ + stack_base = fp ? \ + SCM_FRAME_UPPER_ADDRESS (fp) - 1 \ + : vp->stack_base; \ +} + +#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs] + + +/* + * Function support + */ + +#define ARGS1(a1) SCM a1 = sp[0]; +#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; +#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; + +#define RETURN(x) do { *sp = x; NEXT; } while (0) + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h new file mode 100644 index 000000000..cccb56b9f --- /dev/null +++ b/libguile/vm-expand.h @@ -0,0 +1,103 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef VM_LABEL +#define VM_LABEL(tag) l_##tag +#define VM_OPCODE(tag) scm_op_##tag + +#ifdef HAVE_LABELS_AS_VALUES +#define VM_TAG(tag) VM_LABEL(tag): +#define VM_ADDR(tag) &&VM_LABEL(tag) +#else /* not HAVE_LABELS_AS_VALUES */ +#define VM_TAG(tag) case VM_OPCODE(tag): +#define VM_ADDR(tag) NULL +#endif /* not HAVE_LABELS_AS_VALUES */ +#endif /* VM_LABEL */ + +#undef VM_DEFINE_INSTRUCTION +#undef VM_DEFINE_FUNCTION +#undef VM_DEFINE_LOADER +#ifdef VM_INSTRUCTION_TO_TABLE +/* + * These will go to scm_instruction_table in vm.c + */ +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \ + {VM_OPCODE (tag), name, len, npop, npush}, +#define VM_DEFINE_FUNCTION(tag,name,nargs) \ + {VM_OPCODE (tag), name, 0, nargs, 1}, +#define VM_DEFINE_LOADER(tag,name) \ + {VM_OPCODE (tag), name, -1, 0, 1}, + +#else +#ifdef VM_INSTRUCTION_TO_LABEL +/* + * These will go to jump_table in vm_engine.c + */ +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag), +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag), +#define VM_DEFINE_LOADER(tag,name) VM_ADDR (tag), + +#else +#ifdef VM_INSTRUCTION_TO_OPCODE +/* + * These will go to scm_opcode in vm.h + */ +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag), +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag), +#define VM_DEFINE_LOADER(tag,name) VM_OPCODE (tag), + +#else /* Otherwise */ +/* + * These are directly included in vm_engine.c + */ +#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag) +#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag) +#define VM_DEFINE_LOADER(tag,name) VM_TAG (tag) + +#endif /* VM_INSTRUCTION_TO_OPCODE */ +#endif /* VM_INSTRUCTION_TO_LABEL */ +#endif /* VM_INSTRUCTION_TO_TABLE */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c new file mode 100644 index 000000000..db0ee9b57 --- /dev/null +++ b/libguile/vm-i-loader.c @@ -0,0 +1,229 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + +VM_DEFINE_LOADER (load_integer, "load-integer") +{ + size_t len; + + FETCH_LENGTH (len); + if (len <= 4) + { + long val = 0; + while (len-- > 0) + val = (val << 8) + FETCH (); + SYNC_REGISTER (); + PUSH (scm_from_ulong (val)); + NEXT; + } + else + SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL); +} + +VM_DEFINE_LOADER (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 (load_string, "load-string") +{ + size_t len; + FETCH_LENGTH (len); + SYNC_REGISTER (); + PUSH (scm_from_locale_stringn ((char *)ip, len)); + /* Was: scm_makfromstr (ip, len, 0) */ + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (load_symbol, "load-symbol") +{ + size_t len; + FETCH_LENGTH (len); + SYNC_REGISTER (); + PUSH (scm_from_locale_symboln ((char *)ip, len)); + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (load_keyword, "load-keyword") +{ + size_t len; + FETCH_LENGTH (len); + SYNC_REGISTER (); + PUSH (scm_from_locale_keywordn ((char *)ip, len)); + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (load_program, "load-program") +{ + size_t len; + SCM prog, x; + struct scm_program *p; + + FETCH_LENGTH (len); + SYNC_REGISTER (); + prog = scm_c_make_program (ip, len, program); + p = SCM_PROGRAM_DATA (prog); + ip += len; + + POP (x); + + /* init meta data */ + if (SCM_CONSP (x)) + { + p->meta = x; + POP (x); + } + + /* init object table */ + if (scm_is_vector (x)) + { +#if 0 + if (scm_is_simple_vector (x)) + printf ("is_simple_vector!\n"); + else + printf ("NOT is_simple_vector\n"); +#endif + p->objs = x; + POP (x); + } + + /* init parameters */ + /* NOTE: format defined in system/vm/assemble.scm */ + if (SCM_I_INUMP (x)) + { + int i = SCM_I_INUM (x); + if (-128 <= i && i <= 127) + { + /* 8-bit representation */ + p->nargs = (i >> 6) & 0x03; /* 7-6 bits */ + p->nrest = (i >> 5) & 0x01; /* 5 bit */ + p->nlocs = (i >> 2) & 0x07; /* 4-2 bits */ + p->nexts = i & 0x03; /* 1-0 bits */ + } + else + { + /* 16-bit representation */ + p->nargs = (i >> 12) & 0x07; /* 15-12 bits */ + p->nrest = (i >> 11) & 0x01; /* 11 bit */ + p->nlocs = (i >> 4) & 0x7f; /* 10-04 bits */ + p->nexts = i & 0x0f; /* 03-00 bits */ + } + } + else + { + /* Other cases */ + /* x is #f, and already popped off */ + p->nargs = SCM_I_INUM (sp[-3]); + p->nrest = SCM_I_INUM (sp[-2]); + p->nlocs = SCM_I_INUM (sp[-1]); + p->nexts = SCM_I_INUM (sp[0]); + sp -= 4; + } + + PUSH (prog); + NEXT; +} + +VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1) +{ + SCM sym; + POP (sym); + SYNC_REGISTER (); + PUSH (scm_lookup (sym)); /* might longjmp */ + NEXT; +} + +VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1) +{ + SCM modname, sym; + POP (sym); + POP (modname); + SYNC_REGISTER (); + PUSH (scm_cons (modname, sym)); + NEXT; +} + +VM_DEFINE_LOADER (define, "define") +{ + SCM sym; + size_t len; + + FETCH_LENGTH (len); + SYNC_REGISTER (); + sym = scm_from_locale_symboln ((char *)ip, len); + ip += len; + + SYNC_REGISTER (); + PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T)); + NEXT; +} + +VM_DEFINE_LOADER (late_bind, "late-bind") +{ + SCM sym; + size_t len; + + FETCH_LENGTH (len); + SYNC_REGISTER (); + sym = scm_from_locale_symboln ((char *)ip, len); + ip += len; + + PUSH (sym); + NEXT; +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c new file mode 100644 index 000000000..e1c0dbdb3 --- /dev/null +++ b/libguile/vm-i-scheme.c @@ -0,0 +1,283 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + + +/* + * Predicates + */ + +VM_DEFINE_FUNCTION (not, "not", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_FALSEP (x))); +} + +VM_DEFINE_FUNCTION (not_not, "not-not", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (!SCM_FALSEP (x))); +} + +VM_DEFINE_FUNCTION (eq, "eq?", 2) +{ + ARGS2 (x, y); + RETURN (SCM_BOOL (SCM_EQ_P (x, y))); +} + +VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2) +{ + ARGS2 (x, y); + RETURN (SCM_BOOL (!SCM_EQ_P (x, y))); +} + +VM_DEFINE_FUNCTION (nullp, "null?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_NULLP (x))); +} + +VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (!SCM_NULLP (x))); +} + +VM_DEFINE_FUNCTION (eqv, "eqv?", 2) +{ + ARGS2 (x, y); + if (SCM_EQ_P (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 (equal, "equal?", 2) +{ + ARGS2 (x, y); + if (SCM_EQ_P (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 (pairp, "pair?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_CONSP (x))); +} + +VM_DEFINE_FUNCTION (listp, "list?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (scm_ilength (x) >= 0)); +} + + +/* + * Basic data + */ + +VM_DEFINE_FUNCTION (cons, "cons", 2) +{ + ARGS2 (x, y); + CONS (x, x, y); + RETURN (x); +} + +VM_DEFINE_FUNCTION (car, "car", 1) +{ + ARGS1 (x); + SCM_VALIDATE_CONS (1, x); + RETURN (SCM_CAR (x)); +} + +VM_DEFINE_FUNCTION (cdr, "cdr", 1) +{ + ARGS1 (x); + SCM_VALIDATE_CONS (1, x); + RETURN (SCM_CDR (x)); +} + +VM_DEFINE_FUNCTION (set_car, "set-car!", 2) +{ + ARGS2 (x, y); + SCM_VALIDATE_CONS (1, x); + SCM_SETCAR (x, y); + RETURN (SCM_UNSPECIFIED); +} + +VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2) +{ + ARGS2 (x, y); + SCM_VALIDATE_CONS (1, x); + SCM_SETCDR (x, y); + RETURN (SCM_UNSPECIFIED); +} + + +/* + * Numeric relational tests + */ + +#undef REL +#define REL(crel,srel) \ +{ \ + ARGS2 (x, y); \ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ + RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \ + SYNC_REGISTER (); \ + RETURN (srel (x, y)); \ +} + +VM_DEFINE_FUNCTION (ee, "ee?", 2) +{ + REL (==, scm_num_eq_p); +} + +VM_DEFINE_FUNCTION (lt, "lt?", 2) +{ + REL (<, scm_less_p); +} + +VM_DEFINE_FUNCTION (le, "le?", 2) +{ + REL (<=, scm_leq_p); +} + +VM_DEFINE_FUNCTION (gt, "gt?", 2) +{ + REL (>, scm_gr_p); +} + +VM_DEFINE_FUNCTION (ge, "ge?", 2) +{ + REL (>=, scm_geq_p); +} + + +/* + * Numeric functions + */ + +#undef FUNC1 +#define FUNC1(CEXP,SEXP) \ +{ \ + ARGS1 (x); \ + if (SCM_I_INUMP (x)) \ + { \ + int n = CEXP; \ + if (SCM_FIXABLE (n)) \ + RETURN (SCM_I_MAKINUM (n)); \ + } \ + SYNC_REGISTER (); \ + RETURN (SEXP); \ +} + +#undef FUNC2 +#define FUNC2(CFUNC,SFUNC) \ +{ \ + ARGS2 (x, y); \ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ + { \ + int 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)); \ +} + +VM_DEFINE_FUNCTION (add, "add", 2) +{ + FUNC2 (+, scm_sum); +} + +VM_DEFINE_FUNCTION (sub, "sub", 2) +{ + FUNC2 (-, scm_difference); +} + +VM_DEFINE_FUNCTION (mul, "mul", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_product (x, y)); +} + +VM_DEFINE_FUNCTION (div, "div", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_divide (x, y)); +} + +VM_DEFINE_FUNCTION (quo, "quo", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_quotient (x, y)); +} + +VM_DEFINE_FUNCTION (rem, "rem", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_remainder (x, y)); +} + +VM_DEFINE_FUNCTION (mod, "mod", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_modulo (x, y)); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c new file mode 100644 index 000000000..353b3b8a2 --- /dev/null +++ b/libguile/vm-i-system.c @@ -0,0 +1,672 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +/* This file is included in vm_engine.c */ + + +/* + * Basic operations + */ + +/* This must be the first instruction! */ +VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0) +{ + NEXT; +} + +VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0) +{ + SCM ret; + vp->time += scm_c_get_internal_run_time () - start_time; + HALT_HOOK (); + POP (ret); + FREE_FRAME (); + SYNC_ALL (); + vp->ip = NULL; + scm_dynwind_end (); + return ret; +} + +VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0) +{ + BREAK_HOOK (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0) +{ + DROP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1) +{ + PUSH (SCM_UNDEFINED); + NEXT; +} + +VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1) +{ + SCM x = *sp; + PUSH (x); + NEXT; +} + + +/* + * Object creation + */ + +VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1) +{ + PUSH (SCM_UNSPECIFIED); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1) +{ + PUSH (SCM_BOOL_T); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1) +{ + PUSH (SCM_BOOL_F); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1) +{ + PUSH (SCM_EOL); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1) +{ + PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1) +{ + PUSH (SCM_INUM0); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1) +{ + PUSH (SCM_I_MAKINUM (1)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1) +{ + int h = FETCH (); + int l = FETCH (); + PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1) +{ + PUSH (SCM_MAKE_CHAR (FETCH ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1) +{ + unsigned h = FETCH (); + unsigned l = FETCH (); + unsigned len = ((h << 8) + l); + POP_LIST (len); + NEXT; +} + +VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1) +{ + unsigned h = FETCH (); + unsigned l = FETCH (); + unsigned len = ((h << 8) + l); + POP_LIST (len); + *sp = scm_vector (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0) +{ + POP_LIST_MARK (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0) +{ + POP_LIST_MARK (); + *sp = scm_vector (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0) +{ + SCM l; + POP (l); + for (; !SCM_NULLP (l); l = SCM_CDR (l)) + PUSH (SCM_CAR (l)); + 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) (VARIABLE_REF (v) != SCM_UNDEFINED) + +/* ref */ + +VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1) +{ + register unsigned objnum = FETCH (); + CHECK_OBJECT (objnum); + PUSH (OBJECT_REF (objnum)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1) +{ + PUSH (LOCAL_REF (FETCH ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1) +{ + unsigned int i; + SCM e = external; + for (i = FETCH (); i; i--) + { + CHECK_EXTERNAL(e); + e = SCM_CDR (e); + } + CHECK_EXTERNAL(e); + PUSH (SCM_CAR (e)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1) +{ + SCM x = *sp; + + if (!VARIABLE_BOUNDP (x)) + { + err_args = SCM_LIST1 (x); + /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */ + goto vm_error_unbound; + } + else + { + SCM o = VARIABLE_REF (x); + *sp = o; + } + + NEXT; +} + +VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1) +{ + unsigned objnum = FETCH (); + SCM pair_or_var; + CHECK_OBJECT (objnum); + pair_or_var = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (pair_or_var)) + { + SYNC_REGISTER (); + /* either one of these calls might longjmp */ + SCM mod = scm_resolve_module (SCM_CAR (pair_or_var)); + pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var)); + OBJECT_SET (objnum, pair_or_var); + if (!VARIABLE_BOUNDP (pair_or_var)) + { + err_args = SCM_LIST1 (pair_or_var); + goto vm_error_unbound; + } + } + + PUSH (VARIABLE_REF (pair_or_var)); + NEXT; +} + +/* set */ + +VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0) +{ + LOCAL_SET (FETCH (), *sp); + DROP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0) +{ + unsigned int i; + SCM e = external; + for (i = FETCH (); i; i--) + { + CHECK_EXTERNAL(e); + e = SCM_CDR (e); + } + CHECK_EXTERNAL(e); + SCM_SETCAR (e, *sp); + DROP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0) +{ + VARIABLE_SET (sp[0], sp[-1]); + sp -= 2; + NEXT; +} + +VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0) +{ + unsigned objnum = FETCH (); + SCM pair_or_var; + CHECK_OBJECT (objnum); + pair_or_var = OBJECT_REF (objnum); + + if (!SCM_VARIABLEP (pair_or_var)) + { + SYNC_BEFORE_GC (); + SCM mod = scm_resolve_module (SCM_CAR (pair_or_var)); + /* module_lookup might longjmp */ + pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var)); + OBJECT_SET (objnum, pair_or_var); + } + + VARIABLE_SET (pair_or_var, *sp); + DROP (); + NEXT; +} + + +/* + * branch and jump + */ + +#define BR(p) \ +{ \ + int h = FETCH (); \ + int l = FETCH (); \ + signed short offset = (h << 8) + l; \ + if (p) \ + ip += offset; \ + DROP (); \ + NEXT; \ +} + +VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0) +{ + int h = FETCH (); + int l = FETCH (); + ip += (signed short) (h << 8) + l; + NEXT; +} + +VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0) +{ + BR (!SCM_FALSEP (*sp)); +} + +VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0) +{ + BR (SCM_FALSEP (*sp)); +} + +VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0) +{ + BR (SCM_EQ_P (sp[0], sp--[1])); +} + +VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0) +{ + BR (!SCM_EQ_P (sp[0], sp--[1])); +} + +VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0) +{ + BR (SCM_NULLP (*sp)); +} + +VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0) +{ + BR (!SCM_NULLP (*sp)); +} + + +/* + * Subprogram call + */ + +VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1) +{ + SYNC_BEFORE_GC (); + *sp = scm_c_make_closure (*sp, external); + NEXT; +} + +VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) +{ + SCM x; + nargs = FETCH (); + + vm_call: + x = sp[-nargs]; + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (x)) + { + program = x; + vm_call_program: + CACHE_PROGRAM (); + INIT_ARGS (); + NEW_FRAME (); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } +#ifdef ENABLE_TRAMPOLINE + /* Seems to slow down the fibo test, dunno why */ + /* + * Subr call + */ + switch (nargs) + { + case 0: + { + scm_t_trampoline_0 call = scm_trampoline_0 (x); + if (call) + { + SYNC_ALL (); + *sp = call (x); + NEXT; + } + break; + } + case 1: + { + scm_t_trampoline_1 call = scm_trampoline_1 (x); + if (call) + { + SCM arg1; + POP (arg1); + SYNC_ALL (); + *sp = call (x, arg1); + NEXT; + } + break; + } + case 2: + { + scm_t_trampoline_2 call = scm_trampoline_2 (x); + if (call) + { + SCM arg1, arg2; + POP (arg2); + POP (arg1); + SYNC_ALL (); + *sp = call (x, arg1, arg2); + NEXT; + } + break; + } + } +#endif + /* + * Other interpreted or compiled call + */ + if (!SCM_FALSEP (scm_procedure_p (x))) + { + /* At this point, the stack contains the procedure and each one of its + arguments. */ + SCM args; + POP_LIST (nargs); + POP (args); + SYNC_REGISTER (); + *sp = scm_apply (x, args, SCM_EOL); + NEXT; + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (x)) + { + program = x; + vm_call_cc: + /* Check the number of arguments */ + if (nargs != 1) + scm_wrong_num_args (program); + + /* Reinstate the continuation */ + EXIT_HOOK (); + reinstate_vm_cont (vp, program); + CACHE_REGISTER (); + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + NEXT; + } + + program = x; + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1) +{ + register SCM x; + nargs = FETCH (); + x = sp[-nargs]; + + SCM_TICK; /* allow interrupt here */ + + /* + * Tail recursive call + */ + if (SCM_EQ_P (x, program)) + { + int i; + + /* Move arguments */ + INIT_ARGS (); + sp -= bp->nargs - 1; + for (i = 0; i < bp->nargs; i++) + LOCAL_SET (i, sp[i]); + + /* Drop the first argument and the program itself. */ + sp -= 2; + + /* Call itself */ + ip = bp->base; + APPLY_HOOK (); + NEXT; + } + /* + * Proper tail call + */ + if (SCM_PROGRAM_P (x)) + { + EXIT_HOOK (); + FREE_FRAME (); + program = x; + goto vm_call_program; + } +#ifdef ENABLE_TRAMPOLINE + /* This seems to actually slow down the fibo test -- dunno why */ + /* + * Subr call + */ + switch (nargs) + { + case 0: + { + scm_t_trampoline_0 call = scm_trampoline_0 (x); + if (call) + { + SYNC_ALL (); + *sp = call (x); + goto vm_return; + } + break; + } + case 1: + { + scm_t_trampoline_1 call = scm_trampoline_1 (x); + if (call) + { + SCM arg1; + POP (arg1); + SYNC_ALL (); + *sp = call (x, arg1); + goto vm_return; + } + break; + } + case 2: + { + scm_t_trampoline_2 call = scm_trampoline_2 (x); + if (call) + { + SCM arg1, arg2; + POP (arg2); + POP (arg1); + SYNC_ALL (); + *sp = call (x, arg1, arg2); + goto vm_return; + } + break; + } + } +#endif + + /* + * Other interpreted or compiled call + */ + if (!SCM_FALSEP (scm_procedure_p (x))) + { + SCM args; + POP_LIST (nargs); + POP (args); + SYNC_REGISTER (); + *sp = scm_apply (x, args, SCM_EOL); + goto vm_return; + } + + program = x; + + /* + * Continuation call + */ + if (SCM_VM_CONT_P (program)) + goto vm_call_cc; + + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1) +{ + int len; + SCM ls; + POP (ls); + + nargs = FETCH (); + if (nargs < 2) + goto vm_error_wrong_num_args; + + len = scm_ilength (ls); + if (len < 0) + goto vm_error_wrong_type_arg; + + for (; !SCM_NULLP (ls); ls = SCM_CDR (ls)) + PUSH (SCM_CAR (ls)); + + nargs += len - 2; + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1) +{ + SYNC_BEFORE_GC (); + PUSH (capture_vm_cont (vp)); + POP (program); + nargs = 1; + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) +{ + vm_return: + EXIT_HOOK (); + RETURN_HOOK (); + FREE_FRAME (); + + /* Restore the last program */ + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + CACHE_EXTERNAL (); + CHECK_IP (); + NEXT; +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm.c b/libguile/vm.c new file mode 100644 index 000000000..5ec7d9291 --- /dev/null +++ b/libguile/vm.c @@ -0,0 +1,680 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "vm-bootstrap.h" +#include "frames.h" +#include "instructions.h" +#include "objcodes.h" +#include "programs.h" +#include "vm.h" + +/* I sometimes use this for debugging. */ +#define vm_puts(OBJ) \ +{ \ + scm_display (OBJ, scm_current_error_port ()); \ + scm_newline (scm_current_error_port ()); \ +} + + +/* + * VM Continuation + */ + +scm_t_bits scm_tc16_vm_cont; + + +#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) +#define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) + +static SCM +capture_vm_cont (struct scm_vm *vp) +{ + struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); + p->stack_size = vp->stack_limit - vp->sp; + p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), + "capture_vm_cont"); + p->stack_limit = p->stack_base + p->stack_size - 2; + p->ip = vp->ip; + p->sp = (SCM *) (vp->stack_limit - vp->sp); + p->fp = (SCM *) (vp->stack_limit - vp->fp); + memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM)); + SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p); +} + +static void +reinstate_vm_cont (struct scm_vm *vp, SCM cont) +{ + struct scm_vm *p = SCM_VM_CONT_VP (cont); + if (vp->stack_size < p->stack_size) + { + /* puts ("FIXME: Need to expand"); */ + abort (); + } + vp->ip = p->ip; + vp->sp = vp->stack_limit - (int) p->sp; + vp->fp = vp->stack_limit - (int) p->fp; + memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); +} + +struct vm_unwind_data +{ + struct scm_vm *vp; + SCM *sp; + SCM *fp; + SCM this_frame; +}; + +static void +vm_reset_stack (void *data) +{ + struct vm_unwind_data *w = data; + + w->vp->sp = w->sp; + w->vp->fp = w->fp; + w->vp->this_frame = w->this_frame; +} + +static SCM +vm_cont_mark (SCM obj) +{ + SCM *p; + struct scm_vm *vp = SCM_VM_CONT_VP (obj); + for (p = vp->stack_base; p <= vp->stack_limit; p++) + if (SCM_NIMP (*p)) + scm_gc_mark (*p); + return SCM_BOOL_F; +} + +static scm_sizet +vm_cont_free (SCM obj) +{ + struct scm_vm *p = SCM_VM_CONT_VP (obj); + + scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base"); + scm_gc_free (p, sizeof (struct scm_vm), "vm"); + + return 0; +} + + +/* + * VM Internal functions + */ + +SCM_SYMBOL (sym_vm_run, "vm-run"); +SCM_SYMBOL (sym_vm_error, "vm-error"); + +static scm_byte_t * +vm_fetch_length (scm_byte_t *ip, size_t *lenp) +{ + /* NOTE: format defined in system/vm/conv.scm */ + *lenp = *ip++; + if (*lenp < 254) + return ip; + else if (*lenp == 254) + { + int b1 = *ip++; + int b2 = *ip++; + *lenp = (b1 << 8) + b2; + } + else + { + int b1 = *ip++; + int b2 = *ip++; + int b3 = *ip++; + int b4 = *ip++; + *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4; + } + return ip; +} + +static SCM +vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp) +{ + SCM frame; + SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp); +#if 0 + SCM *src = SCM_FRAME_UPPER_ADDRESS (fp); +#endif + SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp); + + if (!dl) + { + /* The top frame */ + frame = scm_c_make_heap_frame (fp); + fp = SCM_HEAP_FRAME_POINTER (frame); + SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T; + } + else + { + /* Child frames */ + SCM link = SCM_FRAME_HEAP_LINK (dl); + if (!SCM_FALSEP (link)) + link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */ + else + link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest); + frame = scm_c_make_heap_frame (fp); + fp = SCM_HEAP_FRAME_POINTER (frame); + SCM_FRAME_HEAP_LINK (fp) = link; + SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link)); + } + + /* Apparently the intention here is to be able to have a frame on the heap, + but data on the stack, so that you can push as much as you want on the + stack; but I think that it's currently causing borkage with nonlocal exits + and the unwind handler, which reinstates the sp and fp, but it's no longer + pointing at a valid stack frame. So disable for now, we'll get back to + this later. */ +#if 0 + /* Move stack data */ + for (; src <= sp; src++, dest++) + *dest = *src; + *destp = dest; +#endif + + return frame; +} + +static SCM +vm_heapify_frames (SCM vm) +{ + struct scm_vm *vp = SCM_VM_DATA (vm); + if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp))) + { + SCM *dest; + vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest); + vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame); + vp->sp = dest - 1; + } + return vp->this_frame; +} + + +/* + * VM + */ + +#define VM_DEFAULT_STACK_SIZE (16 * 1024) + +#define VM_REGULAR_ENGINE 0 +#define VM_DEBUG_ENGINE 1 + +#if 0 +#define VM_NAME vm_regular_engine +#define VM_ENGINE VM_REGULAR_ENGINE +#include "vm-engine.c" +#undef VM_NAME +#undef VM_ENGINE +#endif + +#define VM_NAME vm_debug_engine +#define VM_ENGINE VM_DEBUG_ENGINE +#include "vm-engine.c" +#undef VM_NAME +#undef VM_ENGINE + +scm_t_bits scm_tc16_vm; + +static SCM the_vm; + +static SCM +make_vm (void) +#define FUNC_NAME "make_vm" +{ + int i; + struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); + + vp->stack_size = VM_DEFAULT_STACK_SIZE; + vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), + "stack-base"); + vp->stack_limit = vp->stack_base + vp->stack_size - 3; + vp->ip = NULL; + vp->sp = vp->stack_base - 1; + vp->fp = NULL; + vp->time = 0; + vp->clock = 0; + vp->options = SCM_EOL; + vp->this_frame = SCM_BOOL_F; + vp->last_frame = SCM_BOOL_F; + vp->last_ip = NULL; + for (i = 0; i < SCM_VM_NUM_HOOKS; i++) + vp->hooks[i] = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); +} +#undef FUNC_NAME + +static SCM +vm_mark (SCM obj) +{ + int i; + struct scm_vm *vp = SCM_VM_DATA (obj); + + /* mark the stack conservatively */ + scm_mark_locations ((SCM_STACKITEM *) vp->stack_base, + sizeof (SCM) * (vp->sp - vp->stack_base + 1)); + + /* mark other objects */ + for (i = 0; i < SCM_VM_NUM_HOOKS; i++) + scm_gc_mark (vp->hooks[i]); + scm_gc_mark (vp->this_frame); + scm_gc_mark (vp->last_frame); + return vp->options; +} + +static scm_sizet +vm_free (SCM obj) +{ + struct scm_vm *vp = SCM_VM_DATA (obj); + + scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM), + "stack-base"); + scm_gc_free (vp, sizeof (struct scm_vm), "vm"); + + return 0; +} + +SCM_SYMBOL (sym_debug, "debug"); + +SCM +scm_vm_apply (SCM vm, SCM program, SCM args) +#define FUNC_NAME "scm_vm_apply" +{ + SCM_VALIDATE_PROGRAM (1, program); + return vm_run (vm, program, args); +} +#undef FUNC_NAME + +/* Scheme interface */ + +SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_vm_version +{ + return scm_from_locale_string (PACKAGE_VERSION); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_the_vm +{ + return the_vm; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_vm_p +{ + return SCM_BOOL (SCM_VM_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_make_vm, +{ + return make_vm (); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_ip +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_sp +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fp +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +#define VM_DEFINE_HOOK(n) \ +{ \ + struct scm_vm *vp; \ + SCM_VALIDATE_VM (1, vm); \ + vp = SCM_VM_DATA (vm); \ + if (SCM_FALSEP (vp->hooks[n])) \ + vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ + return vp->hooks[n]; \ +} + +SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_boot_hook +{ + VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_halt_hook +{ + VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_next_hook +{ + VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_break_hook +{ + VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_enter_hook +{ + VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_apply_hook +{ + VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_exit_hook +{ + VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_return_hook +{ + VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0, + (SCM vm, SCM key), + "") +#define FUNC_NAME s_scm_vm_option +{ + SCM_VALIDATE_VM (1, vm); + return scm_assq_ref (SCM_VM_DATA (vm)->options, key); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, + (SCM vm, SCM key, SCM val), + "") +#define FUNC_NAME s_scm_set_vm_option_x +{ + SCM_VALIDATE_VM (1, vm); + SCM_VM_DATA (vm)->options + = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_stats +{ + SCM stats; + + SCM_VALIDATE_VM (1, vm); + + stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED); + scm_vector_set_x (stats, SCM_I_MAKINUM (0), + scm_from_ulong (SCM_VM_DATA (vm)->time)); + scm_vector_set_x (stats, SCM_I_MAKINUM (1), + scm_from_ulong (SCM_VM_DATA (vm)->clock)); + + return stats; +} +#undef FUNC_NAME + +#define VM_CHECK_RUNNING(vm) \ + if (!SCM_VM_DATA (vm)->ip) \ + SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm)) + +SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_this_frame +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->this_frame; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_last_frame +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->last_frame; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_last_ip +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_save_stack +{ + struct scm_vm *vp; + SCM *dest; + SCM_VALIDATE_VM (1, vm); + vp = SCM_VM_DATA (vm); + + if (vp->fp) + { + vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest); + vp->last_ip = vp->ip; + } + else + { + vp->last_frame = SCM_BOOL_F; + } + + + return vp->last_frame; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fetch_code +{ + int i; + SCM list; + scm_byte_t *ip; + struct scm_instruction *p; + + SCM_VALIDATE_VM (1, vm); + VM_CHECK_RUNNING (vm); + + ip = SCM_VM_DATA (vm)->ip; + p = SCM_INSTRUCTION (*ip); + + list = SCM_LIST1 (scm_str2symbol (p->name)); + for (i = 1; i <= p->len; i++) + list = scm_cons (SCM_I_MAKINUM (ip[i]), list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fetch_stack +{ + SCM *sp; + SCM ls = SCM_EOL; + struct scm_vm *vp; + + SCM_VALIDATE_VM (1, vm); + VM_CHECK_RUNNING (vm); + + vp = SCM_VM_DATA (vm); + for (sp = vp->stack_base; sp <= vp->sp; sp++) + ls = scm_cons (*sp, ls); + return ls; +} +#undef FUNC_NAME + + +/* + * Initialize + */ + +SCM scm_load_compiled_with_vm (SCM file) +{ + SCM program = scm_objcode_to_program (scm_load_objcode (file)); + + return vm_run (the_vm, program, SCM_EOL); +} + +void +scm_bootstrap_vm (void) +{ + static int strappage = 0; + + if (strappage) + return; + + scm_bootstrap_frames (); + scm_bootstrap_instructions (); + scm_bootstrap_objcodes (); + scm_bootstrap_programs (); + + scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); + scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark); + scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free); + + scm_tc16_vm = scm_make_smob_type ("vm", 0); + scm_set_smob_mark (scm_tc16_vm, vm_mark); + scm_set_smob_free (scm_tc16_vm, vm_free); + scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); + + the_vm = scm_permanent_object (make_vm ()); + + scm_c_define ("load-compiled", + scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0, + scm_load_compiled_with_vm)); + + strappage = 1; +} + +void +scm_init_vm (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "vm.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm.h b/libguile/vm.h new file mode 100644 index 000000000..af4c81588 --- /dev/null +++ b/libguile/vm.h @@ -0,0 +1,117 @@ +/* Copyright (C) 2001 Free Software Foundation, Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. */ + +#ifndef _SCM_VM_H_ +#define _SCM_VM_H_ + +#include <libguile.h> + +#define SCM_VM_BOOT_HOOK 0 +#define SCM_VM_HALT_HOOK 1 +#define SCM_VM_NEXT_HOOK 2 +#define SCM_VM_BREAK_HOOK 3 +#define SCM_VM_ENTER_HOOK 4 +#define SCM_VM_APPLY_HOOK 5 +#define SCM_VM_EXIT_HOOK 6 +#define SCM_VM_RETURN_HOOK 7 +#define SCM_VM_NUM_HOOKS 8 + +struct scm_vm { + scm_byte_t *ip; /* instruction pointer */ + SCM *sp; /* stack pointer */ + SCM *fp; /* frame pointer */ + size_t stack_size; /* stack size */ + SCM *stack_base; /* stack base address */ + SCM *stack_limit; /* stack limit address */ + SCM this_frame; /* currrent frame */ + SCM last_frame; /* last frame */ + scm_byte_t *last_ip; /* ip when exception occured */ + SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ + SCM options; /* options */ + unsigned long time; /* time spent */ + unsigned long clock; /* bogos clock */ +}; + +#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x) +#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm)) +#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P) + +extern SCM scm_the_vm (); +extern SCM scm_make_vm (void); +extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); +extern SCM scm_vm_option_ref (SCM vm, SCM key); +extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); + +extern SCM scm_vm_version (void); +extern SCM scm_the_vm (void); +extern SCM scm_vm_p (SCM obj); +extern SCM scm_vm_ip (SCM vm); +extern SCM scm_vm_sp (SCM vm); +extern SCM scm_vm_fp (SCM vm); +extern SCM scm_vm_boot_hook (SCM vm); +extern SCM scm_vm_halt_hook (SCM vm); +extern SCM scm_vm_next_hook (SCM vm); +extern SCM scm_vm_break_hook (SCM vm); +extern SCM scm_vm_enter_hook (SCM vm); +extern SCM scm_vm_apply_hook (SCM vm); +extern SCM scm_vm_exit_hook (SCM vm); +extern SCM scm_vm_return_hook (SCM vm); +extern SCM scm_vm_option (SCM vm, SCM key); +extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); +extern SCM scm_vm_stats (SCM vm); +extern SCM scm_vm_this_frame (SCM vm); +extern SCM scm_vm_last_frame (SCM vm); +extern SCM scm_vm_last_ip (SCM vm); +extern SCM scm_vm_save_stack (SCM vm); +extern SCM scm_vm_fetch_code (SCM vm); +extern SCM scm_vm_fetch_stack (SCM vm); + +extern SCM scm_load_compiled_with_vm (SCM file); + +extern void scm_init_vm (void); + +#endif /* _SCM_VM_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ |