From a98cef7e6c42d40c8d77640030d3eb2697ae647b Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Tue, 22 Aug 2000 15:54:19 +0000 Subject: [PATCH] Initial revision --- AUTHORS | 1 + ChangeLog | 12 + Makefile.am | 7 + NEWS | 0 README | 0 THANKS | 1 + acconfig.h | 4 + acinclude.m4 | 20 + autogen.sh | 6 + configure.in | 15 + doc/Makefile.am | 2 + doc/goops.mail | 78 +++ doc/vm-spec.txt | 402 ++++++++++++++ src/Makefile.am | 47 ++ src/guile-compile.in | 6 + src/guile-vm.c | 58 ++ src/test.scm | 60 +++ src/vm-snarf.h | 88 +++ src/vm.c | 1221 ++++++++++++++++++++++++++++++++++++++++++ src/vm.h | 226 ++++++++ src/vm_engine.c | 132 +++++ src/vm_engine.h | 345 ++++++++++++ src/vm_number.c | 188 +++++++ src/vm_scheme.c | 111 ++++ src/vm_system.c | 549 +++++++++++++++++++ test/Makefile.am | 16 + test/control.scm | 20 + test/procedure.scm | 60 +++ test/queens.scm | 50 ++ test/test.scm | 12 + vm/Makefile.am | 14 + vm/bytecomp.scm | 500 +++++++++++++++++ vm/compile.scm | 310 +++++++++++ vm/shell.scm | 221 ++++++++ vm/types.scm | 367 +++++++++++++ vm/utils.scm | 106 ++++ 36 files changed, 5255 insertions(+) create mode 100644 AUTHORS create mode 100644 ChangeLog create mode 100644 Makefile.am create mode 100644 NEWS create mode 100644 README create mode 100644 THANKS create mode 100644 acconfig.h create mode 100644 acinclude.m4 create mode 100755 autogen.sh create mode 100644 configure.in create mode 100644 doc/Makefile.am create mode 100644 doc/goops.mail create mode 100644 doc/vm-spec.txt create mode 100644 src/Makefile.am create mode 100644 src/guile-compile.in create mode 100644 src/guile-vm.c create mode 100644 src/test.scm create mode 100644 src/vm-snarf.h create mode 100644 src/vm.c create mode 100644 src/vm.h create mode 100644 src/vm_engine.c create mode 100644 src/vm_engine.h create mode 100644 src/vm_number.c create mode 100644 src/vm_scheme.c create mode 100644 src/vm_system.c create mode 100644 test/Makefile.am create mode 100644 test/control.scm create mode 100644 test/procedure.scm create mode 100644 test/queens.scm create mode 100644 test/test.scm create mode 100644 vm/Makefile.am create mode 100644 vm/bytecomp.scm create mode 100644 vm/compile.scm create mode 100644 vm/shell.scm create mode 100644 vm/types.scm create mode 100644 vm/utils.scm diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 000000000..fd76e9211 --- /dev/null +++ b/AUTHORS @@ -0,0 +1 @@ +Keisuke Nishida diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 000000000..56b451d7b --- /dev/null +++ b/ChangeLog @@ -0,0 +1,12 @@ +2000-08-20 Keisuke Nishida + + * Version 0.2 is released. + +2000-08-12 Keisuke Nishida + + * Version 0.1 is released. + +2000-07-29 Keisuke Nishida + + * Version 0.0 is released. + diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 000000000..e38d314b0 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,7 @@ +SUBDIRS = src vm doc test + +EXTRA_DIST = acconfig.h + +MAINTAINERCLEANFILES = COPYING INSTALL config.guess config.sub ltconfig \ + ltmain.sh Makefile.in aclocal.m4 config.h.in stamp-h.in \ + configure missing mkinstalldirs install-sh texinfo.tex diff --git a/NEWS b/NEWS new file mode 100644 index 000000000..e69de29bb diff --git a/README b/README new file mode 100644 index 000000000..e69de29bb diff --git a/THANKS b/THANKS new file mode 100644 index 000000000..da16a3a50 --- /dev/null +++ b/THANKS @@ -0,0 +1 @@ +Guile VM is motivated by QScheme. diff --git a/acconfig.h b/acconfig.h new file mode 100644 index 000000000..834401771 --- /dev/null +++ b/acconfig.h @@ -0,0 +1,4 @@ +/* Define if compiler supports gcc's "labels as values" (aka computed goto) + * feature (which is used to speed up instruction dispatch in the interpreter). + */ +#undef HAVE_LABELS_AS_VALUES diff --git a/acinclude.m4 b/acinclude.m4 new file mode 100644 index 000000000..5f8e76612 --- /dev/null +++ b/acinclude.m4 @@ -0,0 +1,20 @@ +dnl check for gcc's "labels as values" feature +AC_DEFUN(AC_C_LABELS_AS_VALUES, +[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values, +[AC_TRY_COMPILE([ +int foo(int); +int foo(i) +int i; { +static void *label[] = { &&l1, &&l2 }; +goto *label[i]; +l1: return 1; +l2: return 2; +} +], +[int i;], +ac_cv_labels_as_values=yes, +ac_cv_labels_as_values=no)]) +if test "$ac_cv_labels_as_values" = yes; then +AC_DEFINE(HAVE_LABELS_AS_VALUES) +fi +]) diff --git a/autogen.sh b/autogen.sh new file mode 100755 index 000000000..15741faed --- /dev/null +++ b/autogen.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +aclocal +autoheader +automake -a +autoconf diff --git a/configure.in b/configure.in new file mode 100644 index 000000000..d0f58bb29 --- /dev/null +++ b/configure.in @@ -0,0 +1,15 @@ +AC_INIT(src/guile-vm.c) +AM_INIT_AUTOMAKE(guile-vm, 0.2) +AM_CONFIG_HEADER(src/config.h) + +GUILE_FLAGS +if test "`guile -c '(display (string>=? (version) "1.4.1"))'`" != "#t"; then + AC_MSG_ERROR([Your Guile is too old. You need guile-1.4.1 or later.]) +fi + +AC_PROG_CC +AC_PROG_LN_S +AM_PROG_LIBTOOL +AC_C_LABELS_AS_VALUES + +AC_OUTPUT(Makefile src/Makefile vm/Makefile doc/Makefile test/Makefile) diff --git a/doc/Makefile.am b/doc/Makefile.am new file mode 100644 index 000000000..3ab2c4b5b --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1,2 @@ +EXTRA_DIST = vm-spec.txt +MAINTAINERCLEANFILES = Makefile.in diff --git a/doc/goops.mail b/doc/goops.mail new file mode 100644 index 000000000..305e80403 --- /dev/null +++ b/doc/goops.mail @@ -0,0 +1,78 @@ +From: Mikael Djurfeldt +Subject: Re: After GOOPS integration: Computation with native types! +To: Keisuke Nishida +Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com +Cc: djurfeldt@nada.kth.se +Date: 17 Aug 2000 03:01:13 +0200 + +Keisuke Nishida writes: + +> Do I need to include some special feature in my VM? Hmm, but maybe +> I shouldn't do that now... + +Probably not, so I probably shouldn't answer, but... :) + +You'll need to include some extremely efficient mechanism to do +multi-method dispatch. The SCM_IM_DISPATCH form, with its +implementation at line 2250 in eval.c, is the current basis for +efficient dispatch in GOOPS. + +I think we should develop a new instruction for the VM which +corresponds to the SCM_IM_DISPATCH form. + +This form serves both the purpose to map argument types to the correct +code, and as a cache of compiled methods. + +Notice that I talk about cmethods below, not methods. In GOOPS, the +GF has a set of methods, but each method has a "code-table" mapping +argument types to code compiled for those particular concrete types. +(So, in essence, GOOPS methods abstractly do a deeper level of type +dispatch.) + +The SCM_IM_DISPATCH form has two shapes, depending on whether we use +sequential search (few cmethods) or hashed lookup (many cmethods). + +Shape 1: + + (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF) + +Shape 2: + + (#@dispatch args N-SPECIALIZED HASHSET MASK + #((TYPE1 ... ENV FORMALS FORM1 ...) ...) + GF) + +`args' is (I hope!) a now historic obscure optimization. + +N-SPECIALIZED is the maximum number of arguments t do type checking +on. This is used early termination of argument checking where the +already checked arguments are enough to pick out the cmethod. + +The vector is the cache proper. + +During sequential search the argument types are simply checked against +each entry. + +The method for hashed dispatch is described in: + +http://www.parc.xerox.com/csl/groups/sda/publications/papers/Kiczales-Andreas-PCL + +In this method, each class has a hash code. Dispatch means summing +the hash codes for all arguments (up til N-SPECIALIZED) and using the +sum to pick a location in the cache. The cache is sequentially +searched for an argument type match from that point. + +Kiczales introduced a clever method to maximize the probability of a +direct cache hit. We actually have 8 separate sets of hash codes for +all types. The hash set to use is selected specifically per GF and is +optimized to give fastest average hit. + + +What we could try to do as soon as the VM is complete enough is to +represent the cmethods as chunks of byte code. In the current GOOPS +code, the compilation step (which is currently empty) is situated in +`compile-cmethod' in guile-oops/compile.scm. [Apologies for the +terrible code. That particular part was written at Arlanda airport +after a sleepless night (packing luggage, not coding), on my way to +visit Marius (who, BTW, didn't take GOOPS seriously. ;-)] + diff --git a/doc/vm-spec.txt b/doc/vm-spec.txt new file mode 100644 index 000000000..e3a04f5f1 --- /dev/null +++ b/doc/vm-spec.txt @@ -0,0 +1,402 @@ +Guile VM Specification -*- outline -*- +====================== +Updated: $Date: 2000/08/22 15:54:19 $ + +* Introduction + +A Guile VM has a set of registers and its own stack memory. Guile may +have more than one VM's. Each VM may execute at most one program at a +time. Guile VM is a CISC system so designed as to execute Scheme and +other languages efficiently. + +** Registers + + pc - Program counter ;; ip (instruction poiner) is better? + sp - Stack pointer + bp - Base pointer + ac - Accumulator + +** Engine + +A VM may have one of three engines: reckless, regular, or debugging. +Reckless engine is fastest but dangerous. Regular engine is normally +fail-safe and reasonably fast. Debugging engine is safest and +functional but very slow. + +** Memory + +Stack is the only memory that each VM owns. The other memory is shared +memory that is shared among every VM and other part of Guile. + +** Program + +A VM program consists of a bytecode that is executed and an environment +in which execution is done. Each program is allocated in the shared +memory and may be executed by any VM. A program may call other programs +within a VM. + +** Instruction + +Guile VM has dozens of system instructions and (possibly) hundreds of +functional instructions. Some Scheme procedures such as cons and car +are implemented as VM's builtin functions, which are very efficient. +Other procedures defined outside of the VM are also considered as VM's +functional features, since they do not change the state of VM. +Procedures defined within the VM are called subprograms. + +Most instructions deal with the accumulator (ac). The VM stores all +results from functions in ac, instead of pushing them into the stack. +I'm not sure whether this is a good thing or not. + +* Variable Management + +A program may have access to local variables, external variables, and +top-level variables. + +** Local/external variables + +A stack is logically divided into several blocks during execution. A +"block" is such a unit that maintains local variables and dynamic chain. +A "frame" is an upper level unit that maintains subprogram calls. + + Stack + dynamic | | | | + chain +==========+ - = + | |local vars| | | + `-|block data| | block | + /|frame data| | | + | +----------+ - | + | |local vars| | | frame + `-|block data| | | + /+----------+ - | + | |local vars| | | + `-|block data| | | + /+==========+ - = + | |local vars| | | + `-|block data| | | + /|frame data| | | + | +----------+ - | + | | | | | + +The first block of each frame may look like this: + + Address Data + ------- ---- + xxx0028 Local variable 2 + xxx0024 Local variable 1 + bp ->xxx0020 Local variable 0 + xxx001c Local link (block data) + xxx0018 External link (block data) + xxx0014 Stack pointer (block data) + xxx0010 Return address (frame data) + xxx000c Parent program (frame data) + +The base pointer (bp) always points to the lowest address of local +variables of the recent block. Local variables are referred as "bp[n]". +The local link field has a pointer to the dynamic parent of the block. +The parent's variables are referred as "bp[-1][n]", and grandparent's +are "bp[-1][-1][n]". Thus, any local variable is represented by its +depth and offset from the current bp. + +A variable may be "external", which is allocated in the shared memory. +The external link field of a block has a pointer to such a variable set, +which I call "fragment" (what should I call?). A fragment has a set of +variables and its own chain. + + local external + chain| | chain + | +-----+ .--------, | + `-|block|--+->|fragment|-' + /+-----+ | `--------'\, + `-|block|--' | + /+-----+ .--------, | + `-|block|---->|fragment|-' + +-----+ `--------' + | | + +An external variable is referred as "bp[-2]->variables[n]" or +"bp[-2]->link->...->variables[n]". This is also represented by a pair +of depth and offset. At any point of execution, the value of bp +determines the current local link and external link, and thus the +current environment of a program. + +Other data fields are described later. + +** Top-level variables + +Guile VM uses the same top-level variables as the regular Guile. A +program may have direct access to vcells. Currently this is done by +calling scm_intern0, but a program is possible to have any top-level +environment defined by the current module. + +*** Scheme and VM variable + +Let's think about the following Scheme code as an example: + + (define (foo a) + (lambda (b) (list foo a b))) + +In the lambda expression, "foo" is a top-level variable, "a" is an +external variable, and "b" is a local variable. + +When a VM executes foo, it allocates a block for "a". Since "a" may be +externally referred from the closure, the VM creates a fragment with a +copy of "a" in it. When the VM evaluates the lambda expression, it +creates a subprogram (closure), associating the fragment with the +subprogram as its external environment. When the closure is executed, +its environment will look like this: + + block Top-level: foo + +-------------+ + |local var: b | fragment + +-------------+ .-----------, + |external link|---->|variable: a| + +-------------+ `-----------' + +The fragment remains as long as the closure exists. + +** Addressing mode + +Guile VM has five addressing modes: + + o Real address + o Local position + o External position + o Top-level location + o Immediate object + +Real address points to the address in the real program and is only used +with the program counter (pc). + +Local position and external position are represented as a pair of depth +and offset from bp, as described above. These are base relative +addresses, and the real address may vary during execution. + +Top-level location is represented as a Guile's vcell. This location is +determined at loading time, so the use of this address is efficient. + +Immediate object is not an address but gives an instruction an Scheme +object directly. + +[ We'll also need dynamic scope addressing to support Emacs Lisp? ] + +*** At a Glance + +Guile VM has a set of instructions for each instruction family. `%load' +is, for example, a family to load an object from memory and set the +accumulator (ac). There are four basic `%load' instructions: + + %loadl - Local addressing + %loade - External addressing + %loadt - Top-level addressing + %loadi - Immediate addressing + +A possible program code may look like this: + + %loadl (0 . 1) ; ac = local[0][1] + %loade (2 . 3) ; ac = external[2][3] + %loadt (foo . #) ; ac = # + %loadi "hello" ; ac = "hello" + +One instruction that uses real addressing is `%jump', which changes the +value of the program counter: + + %jump 0x80234ab8 ; pc = 0x80234ab8 + +* Program Execution + +Overall procedure: + + 1. A source program is compiled into a bytecode. + + 2. A bytecode is given an environment and becomes a program. + + 3. A VM starts execution, creating a frame for it. + + 4. Whenever a program calls a subprogram, a new frame is created for it. + + 5. When a program finishes execution, it returns a value, and the VM + continues execution of the parent program. + + 6. When all programs terminated, the VM returns the final value and stops. + +** Environment + +Local variable: + + (let ((a 1) (b 2) (c 3)) (+ a b c)) -> + + %pushi 1 ; a + %pushi 2 ; b + %pushi 3 ; c + %bind 3 ; create local bindings + %pushl (0 . 0) ; local variable a + %pushl (0 . 1) ; local variable b + %pushl (0 . 2) ; local variable c + add 3 ; ac = a + b + c + %unbind ; remove local bindings + +External variable: + + (define foo (let ((n 0)) (lambda () n))) + + %pushi 0 ; n + %bind 1 ; create local bindings + %export [0] ; make it an external variable + %make-program # ; create a program in this environment + %unbind ; remove local bindings + %savet (foo . #) ; save the program in foo + + (foo) -> + + %loadt (foo . #) ; program has an external link + %call 0 ; change the current external link + %loade (0 . 0) ; external variable n + %return ; recover the external link + +Top-level variable: + + foo -> + + %loadt (foo . #) ; top-level variable foo + +** Flow control + + (if #t 1 0) -> + + %loadi #t + %br-if-not L1 + %loadi 1 + %jump L2 + L1: %loadi 0 + L2: + +** Function call + +Builtin function: + + (1+ 2) -> + + %loadi 2 ; ac = 2 + 1+ ; one argument + + (+ 1 2) -> + + %pushi 1 ; 1 -> stack + %loadi 2 ; ac = 2 + add2 ; two argument + + (+ 1 2 3) -> + + %pushi 1 ; 1 -> stack + %pushi 2 ; 2 -> stack + %pushi 3 ; 3 -> stack + add 3 ; many argument + +External function: + + (version) -> + + %func0 (version . #) ; no argument + + (display "hello") -> + + %loadi "hello" + %func1 (display . #) ; one argument + + (open-file "file" "w") -> + + %pushi "file" + %loadi "w" + %func2 (open-file . #) ; two arguments + + (equal 1 2 3) + + %pushi 1 + %pushi 2 + %pushi 3 + %loadi 3 ; the number of arguments + %func (equal . #) ; many arguments + +** Subprogram call + + (define (plus a b) (+ a b)) + (plus 1 2) -> + + %pushi 1 ; argument 1 + %pushi 2 ; argument 2 + %loadt (plus . #) ; load the program + %call 2 ; call it with two arguments + %pushl (0 . 0) ; argument 1 + %loadl (0 . 1) ; argument 2 + add2 ; ac = 1 + 2 + %return ; result is 3 + +* Instruction Set + +The Guile VM instruction set is roughly divided two groups: system +instructions and functional instructions. System instructions control +the execution of programs, while functional instructions provide many +useful calculations. By convention, system instructions begin with a +letter `%'. + +** Environment control instructions + +- %alloc +- %bind +- %export +- %unbind + +** Subprogram control instructions + +- %make-program +- %call +- %return + +** Data control instructinos + +- %push +- %pushi +- %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3 +- %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3 +- %pusht + +- %loadi +- %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3 +- %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3 +- %loadt + +- %savei +- %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3 +- %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3 +- %savet + +** Flow control instructions + +- %br-if +- %br-if-not +- %jump + +** Function call instructions + +- %func, %func0, %func1, %func2 + +** Scheme buitin functions + +- cons +- car +- cdr + +** Mathematical buitin functions + +- 1+ +- 1- +- add, add2 +- sub, sub2, minus +- mul2 +- div2 +- lt2 +- gt2 +- le2 +- ge2 +- num-eq2 diff --git a/src/Makefile.am b/src/Makefile.am new file mode 100644 index 000000000..552690df9 --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1,47 @@ +bin_PROGRAMS = guile-vm +guile_vm_SOURCES = guile-vm.c +guile_vm_LDADD = libguilevm.la +guile_vm_LDFLAGS = $(GUILE_LDFLAGS) + +bin_SCRIPTS = guile-compile + +lib_LTLIBRARIES = libguilevm.la +libguilevm_la_SOURCES = vm.c +libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic +noinst_HEADERS = vm.h vm_engine.h vm-snarf.h +EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \ + test.scm guile-compile.in +BUILT_SOURCES = vm_system.vi vm_scheme.vi vm_number.vi \ + vm_system.op vm_scheme.op vm_number.op vm.x + +CFLAGS = -g -O2 -Wall +INCLUDES = $(GUILE_CFLAGS) +CLEANFILES = $(bin_SCRIPTS) +DISTCLEANFILES = $(BUILT_SOURCES) +MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in + +SNARF = guile-snarf +SUFFIXES = .x .vi .op +.c.x: + $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + || { rm $@; false; } + +.c.vi: + $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \ + || { rm $@; false; } + +.c.op: + $(SNARF) -DSCM_SNARF_OPCODE $(DEFS) $(INCLUDES) $(CPPFLAGS) \ + $(CFLAGS) $< > $@ || { rm $@; false; } + +$(BUILT_SOURCES): config.h vm-snarf.h + +guile-compile: guile-compile.in + sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \ + $< > $@ + +test: all + $(bin_PROGRAMS) -s test.scm + +debug-test: all + $(bin_PROGRAMS) -s test.scm debug diff --git a/src/guile-compile.in b/src/guile-compile.in new file mode 100644 index 000000000..1589d220e --- /dev/null +++ b/src/guile-compile.in @@ -0,0 +1,6 @@ +#!@bindir@/@PACKAGE@ -s +!# + +(use-modules (vm compile)) + +(for-each compile-file (cdr (command-line))) diff --git a/src/guile-vm.c b/src/guile-vm.c new file mode 100644 index 000000000..5d3c1c1a6 --- /dev/null +++ b/src/guile-vm.c @@ -0,0 +1,58 @@ +/* Copyright (C) 2000 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. */ + +#include + +extern void scm_init_vm_vm_module (); + +static void +inner_main (void *closure, int argc, char **argv) +{ + scm_init_vm_vm_module (); + scm_shell (argc, argv); +} + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; /* never reached */ +} diff --git a/src/test.scm b/src/test.scm new file mode 100644 index 000000000..85d747fea --- /dev/null +++ b/src/test.scm @@ -0,0 +1,60 @@ + +(set! %load-path (cons ".." %load-path)) +(use-modules (vm vm)) +(use-modules (vm shell)) +(use-modules (vm compile)) +(use-modules (ice-9 syncase)) + +(define *verbose-output* (if (null? (cdr (command-line))) #f #t)) + +(define test-list + '((1 1) + ((1- 1) 0) + ((+ (+ 1) (- 2)) -1) + ((+ (+ 1 2) (- 1 2) (* 1 2) (/ 1 2)) 4.5) + ((* (- 1 2 3) (+ 1.2 3.4) (/ 1 2 4)) -2.3) + ((let ((a 1)) a) 1) + ((let ((a 1) (b 2)) b) 2) + ((let* ((a 1) (a 2)) a) 2) + ((let ((a 1)) (let ((b 2)) a)) 1) + ((let ((a 1) (b 2) (c 3)) + ((lambda (d e f) + ((lambda (g h i) + ((lambda () (list a b d f h i)))) + 7 8 9)) + 4 5 6)) + (1 2 4 6 8 9)) + ((do ((i 3 (1- i)) (n 0 (+ n i))) ((< i 0) n)) 6) + ((let () (define (foo a) a) (foo 1)) 1) + ((begin (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) + (fib 3)) 2) + ((begin (define (loop i l) (if (< i l) (loop (+ 1 i) l) l)) + (loop 0 3)) 3) +; ((call-with-current-continuation (lambda (c) (c 1) 2)) 1) + ((map 1+ '(1 2 3)) (2 3 4)) + )) + +(define (test vm form answer) + (format #t "Testing ~S = ~S ..." form answer) + (let ((result (vm-run vm (compile form)))) + (if (equal? result answer) + (display "OK\n") + (format #t "failed: ~S\n" result)))) + +(define (debug-test vm form answer) + (format #t "Testing ~S = ~S ...\n" form answer) + (let ((result (begin + (vm-set-option! vm 'verbose *verbose-output*) + (vm-trace vm form)))) + (if (equal? result answer) + (display "OK\n") + (format #t "failed: ~S\n" result)))) + +(let ((vm (make-vm))) + (display "=== Testing the debug engine ===\n") + (vm-set-option! vm 'debug #t) + (for-each (lambda (q) (apply debug-test vm q)) test-list) + (display "\n=== Testing the fast engine ===\n") + (vm-set-option! vm 'debug #f) + (for-each (lambda (q) (apply test vm q)) test-list) + (display "done\n")) diff --git a/src/vm-snarf.h b/src/vm-snarf.h new file mode 100644 index 000000000..8956e32c9 --- /dev/null +++ b/src/vm-snarf.h @@ -0,0 +1,88 @@ +/* Copyright (C) 2000 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_SNARF_H +#define VM_SNARF_H + +#include "config.h" + +#define VM_LABEL(TAG) l_##TAG## +#define VM_OPCODE(TAG) 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 */ + +#ifndef SCM_MAGIC_SNARFER + +/* + * These are directly included in vm_engine.c + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG) +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG) + +#else /* SCM_MAGIC_SNARFER */ +#ifndef SCM_SNARF_OPCODE + +/* + * These will go to *.vi + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \ + SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, VM_ADDR(TAG), SCM_BOOL_F, NULL, 0, 0}, +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \ + SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, VM_ADDR(TAG), SCM_BOOL_F, SNAME, NARGS, RESTP}, + +#else /* SCM_SNARF_OPCODE */ + +/* + * These will go to *.op + */ +#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) SCM_SNARF_INIT_START VM_OPCODE(TAG), +#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) SCM_SNARF_INIT_START VM_OPCODE(TAG), + +#endif /* SCM_SNARF_OPCODE */ +#endif /* SCM_MAGIC_SNARFER */ + +#endif /* not VM_SNARF_H */ diff --git a/src/vm.c b/src/vm.c new file mode 100644 index 000000000..51fa23a8c --- /dev/null +++ b/src/vm.c @@ -0,0 +1,1221 @@ +/* Copyright (C) 2000 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. */ + +#define SCM_DEBUG_TYPING_STRICTNESS 0 +#include "config.h" +#include "vm.h" + +/* default stack size in the number of SCM */ +#define VM_DEFAULT_STACK_SIZE (1 * 1024) /* = 128KB */ +#define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */ + +/* I sometimes use this for debugging. */ +#define vm_puts(OBJ) \ +{ \ + scm_display (OBJ, scm_def_errp); \ + scm_newline (scm_def_errp); \ +} + + +/* + * Instruction + */ + +#define INSTRUCTION_HASH_SIZE op_last +#define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE) + +/* These variables are defined in VM engines when they are first called. */ +static struct scm_instruction *scm_regular_instruction_table = 0; +static struct scm_instruction *scm_debug_instruction_table = 0; + +/* Hash table for finding instructions from addresses */ +static struct inst_hash { + void *addr; + struct scm_instruction *inst; + struct inst_hash *next; +} *scm_instruction_hash_table[INSTRUCTION_HASH_SIZE]; + +static long scm_instruction_tag; + +static SCM +make_instruction (struct scm_instruction *instp) +{ + SCM_RETURN_NEWSMOB (scm_instruction_tag, instp); +} + +static int +print_instruction (SCM obj, SCM port, scm_print_state *pstate) +{ + scm_puts ("#name, port); + scm_putc ('>', port); + return 1; +} + +static void +init_instruction_type () +{ + scm_instruction_tag = scm_make_smob_type ("instruction", 0); + scm_set_smob_print (scm_instruction_tag, print_instruction); +} + +/* C interface */ + +static struct scm_instruction * +find_instruction_by_name (const char *name) +{ + struct scm_instruction *p; + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + if (strcmp (name, p->name) == 0) + return p; + return 0; +} + +static struct scm_instruction * +find_instruction_by_code (SCM code) +{ + struct inst_hash *p; + void *addr = SCM_CODE_TO_ADDR (code); + for (p = scm_instruction_hash_table[INSTRUCTION_HASH (addr)]; p; p = p->next) + if (p->addr == addr) + return p->inst; + return 0; +} + +#ifdef HAVE_LABELS_AS_VALUES +static void * +instruction_code_to_debug_addr (SCM code) +{ + struct scm_instruction *p = find_instruction_by_code (code); + return scm_debug_instruction_table[p->opcode].addr; +} +#endif + +/* Scheme interface */ + +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_system_instruction_p, "system-instruction?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_system_instruction_p +{ + return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_functional_instruction_p +{ + return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_instruction_name_p +{ + SCM_VALIDATE_SYMBOL (1, name); + return SCM_BOOL (find_instruction_by_name (SCM_CHARS (name))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0, + (SCM name), +"") +#define FUNC_NAME s_scm_symbol_to_instruction +{ + struct scm_instruction *p; + SCM_VALIDATE_SYMBOL (1, name); + + p = find_instruction_by_name (SCM_CHARS (name)); + if (!p) + SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name)); + + return p->obj; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_instruction_list +{ + SCM list = SCM_EOL; + struct scm_instruction *p; + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + list = scm_cons (p->obj, list); + return scm_reverse_x (list, SCM_EOL); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_opcode +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_name +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_type +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_scheme_name +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) + return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname)); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0, + (SCM inst), +"") +#define FUNC_NAME s_scm_instruction_arity +{ + SCM_VALIDATE_INSTRUCTION (1, inst); + if (SCM_FUNCTIONAL_INSTRUCTION_P (inst)) + { + struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst); + return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp)); + } + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + + +/* + * Bytecode + */ + +static long scm_bytecode_tag; + +static SCM +make_bytecode (int size) +{ + struct scm_bytecode *p + = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode"); + p->size = size; + SCM_RETURN_NEWSMOB (scm_bytecode_tag, p); +} + +static SCM +mark_bytecode (SCM bytecode) +{ + int i; + struct scm_instruction *p; + + int size = SCM_BYTECODE_SIZE (bytecode); + SCM *base = SCM_BYTECODE_BASE (bytecode); + + for (i = 0; i < size; i++) + { + p = find_instruction_by_code (base[i]); + switch (p->type) + { + case INST_NONE: + break; + case INST_SCM: + case INST_TOP: + case INST_EXT: + case INST_CODE: + scm_gc_mark (base[++i]); + break; + case INST_INUM: /* a fixed integer; we don't need to mark it */ + case INST_ADDR: /* real memory address; we shouldn't mark it! */ + i++; + } + } + return SCM_BOOL_F; +} + +static int +print_bytecode (SCM obj, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); + return 1; +} + +static scm_sizet +free_bytecode (SCM bytecode) +{ + int size = (sizeof (struct scm_bytecode) + + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM))); + if (SCM_BYTECODE_EXTS (bytecode)) + { + size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int); + scm_must_free (SCM_BYTECODE_EXTS (bytecode)); + } + scm_must_free (SCM_BYTECODE_DATA (bytecode)); + return size; +} + +static void +init_bytecode_type () +{ + scm_bytecode_tag = scm_make_smob_type ("bytecode", 0); + scm_set_smob_mark (scm_bytecode_tag, mark_bytecode); + scm_set_smob_print (scm_bytecode_tag, print_bytecode); + scm_set_smob_free (scm_bytecode_tag, free_bytecode); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_bytecode_p +{ + return SCM_BOOL (SCM_BYTECODE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0, + (SCM code), +"") +#define FUNC_NAME s_scm_make_bytecode +{ + int i, size, len, offset; + SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode; + SCM *old, *new, *address; + + /* Type check */ + SCM_VALIDATE_VECTOR (1, code); + SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2); + header = SCM_VELTS (code)[0]; + body = SCM_VELTS (code)[1]; + SCM_VALIDATE_VECTOR (1, header); + SCM_VALIDATE_VECTOR (2, body); + SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5); + nreqs = SCM_VELTS (header)[0]; + restp = SCM_VELTS (header)[1]; + nvars = SCM_VELTS (header)[2]; + nexts = SCM_VELTS (header)[3]; + exts = SCM_VELTS (header)[4]; + SCM_VALIDATE_INUM (1, nreqs); + SCM_VALIDATE_BOOL (2, restp); + SCM_VALIDATE_INUM (3, nvars); + SCM_VALIDATE_INUM (4, nexts); + SCM_VALIDATE_VECTOR (5, exts); + + /* Create a new bytecode */ + size = SCM_LENGTH (body); + old = SCM_VELTS (body); + bytecode = make_bytecode (size); + new = SCM_BYTECODE_BASE (bytecode); + + /* Initialize the header */ + SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs); + SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1; + SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars); + SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts); + len = SCM_LENGTH (exts); + if (len == 0) + { + SCM_BYTECODE_EXTS (bytecode) = NULL; + } + else + { + SCM_BYTECODE_EXTS (bytecode) = + scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME); + SCM_BYTECODE_EXTS (bytecode)[0] = len; + for (i = 0; i < len; i++) + SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]); + } + + /* Initialize the body */ + for (i = 0; i < size; i++) + { + struct scm_instruction *p; + + /* Process instruction */ + if (!SCM_SYMBOLP (old[i]) + || !(p = find_instruction_by_name (SCM_CHARS (old[i])))) + SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i])); + new[i] = SCM_ADDR_TO_CODE (p->addr); + + /* Process arguments */ + if (p->type == INST_NONE) + continue; + if (++i >= size) + SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL); + switch (p->type) + { + case INST_NONE: + /* never come here */ + case INST_INUM: + SCM_VALIDATE_INUM (1, old[i]); + /* fall through */ + case INST_SCM: + /* just copy */ + new[i] = old[i]; + break; + case INST_TOP: + /* top-level variable */ + SCM_VALIDATE_SYMBOL (1, old[i]); + new[i] = scm_intern0 (SCM_CHARS (old[i])); + break; + case INST_EXT: + /* just copy for now */ + SCM_VALIDATE_CONS (1, old[i]); + SCM_VALIDATE_INUM (1, SCM_CAR (old[i])); + SCM_VALIDATE_INUM (1, SCM_CDR (old[i])); + new[i] = old[i]; + break; + case INST_CODE: + /* another bytecode */ + new[i] = scm_make_bytecode (old[i]); + break; + case INST_ADDR: + /* real address */ + SCM_VALIDATE_INUM (1, old[i]); + /* Without the following intermediate variables, type conversion + fails on my machine. Casting doesn't work well, why? */ + offset = SCM_INUM (old[i]); + address = new + offset; + new[i] = SCM_VM_MAKE_ADDRESS (address); + break; + } + } + return bytecode; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0, + (SCM bytecode), +"") +#define FUNC_NAME s_scm_bytecode_decode +{ + int i, size, offset; + SCM code, *old, *new; + + SCM_VALIDATE_BYTECODE (1, bytecode); + + size = SCM_BYTECODE_SIZE (bytecode); + old = SCM_BYTECODE_BASE (bytecode); + code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); + new = SCM_VELTS (code); + + for (i = 0; i < size; i++) + { + struct scm_instruction *p; + + /* Process instruction */ + p = find_instruction_by_code (old[i]); + if (!p) + { + broken: + SCM_MISC_ERROR ("Broken bytecode", SCM_EOL); + } + new[i] = scm_instruction_name (p->obj); + + /* Process arguments */ + if (p->type == INST_NONE) + continue; + if (++i >= size) + goto broken; + switch (p->type) + { + case INST_NONE: + /* never come here */ + case INST_INUM: + case INST_SCM: + case INST_EXT: + /* just copy */ + new[i] = old[i]; + break; + case INST_TOP: + /* top-level variable */ + new[i] = SCM_CAR (old[i]); + break; + case INST_CODE: + /* another bytecode */ + new[i] = scm_bytecode_decode (old[i]); + break; + case INST_ADDR: + /* program address */ + offset = SCM_VM_ADDRESS (old[i]) - old; + new[i] = SCM_MAKINUM (offset); + break; + } + } + return code; +} +#undef FUNC_NAME + + +/* + * Program + */ + +static long scm_program_tag; + +static SCM +make_program (SCM bytecode, SCM parent) +{ + SCM env = SCM_PROGRAM_P (parent) ? SCM_PROGRAM_ENV (parent) : SCM_BOOL_F; + int nexts = SCM_BYTECODE_NEXTS (bytecode); + + if (nexts) + { + SCM tmp = SCM_VM_MAKE_EXTERNAL (nexts); + SCM_VM_EXTERNAL_LINK (tmp) = env; + env = tmp; + } + + SCM_RETURN_NEWSMOB2 (scm_program_tag, + SCM_UNPACK (bytecode), + SCM_UNPACK (env)); +} + +static SCM +mark_program (SCM program) +{ + scm_gc_mark (SCM_PROGRAM_CODE (program)); + return SCM_PROGRAM_ENV (program); +} + +static SCM scm_program_name (SCM program); + +static int +print_program (SCM obj, SCM port, scm_print_state *pstate) +{ + SCM name = scm_program_name (obj); + scm_puts ("#', port); + return 1; +} + +static void +init_program_type () +{ + scm_program_tag = scm_make_smob_type ("program", 0); + scm_set_smob_mark (scm_program_tag, mark_program); + scm_set_smob_print (scm_program_tag, print_program); +} + +/* 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_make_program, "make-program", 2, 0, 0, + (SCM bytecode, SCM parent), +"") +#define FUNC_NAME s_scm_make_program +{ + SCM_VALIDATE_BYTECODE (1, bytecode); + return make_program (bytecode, parent); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0, + (SCM program), +"") +#define FUNC_NAME s_scm_program_name +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_object_property (program, scm_sym_name); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0, + (SCM program), +"") +#define FUNC_NAME s_scm_program_code +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_CODE (program); +} +#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_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program)); +} +#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_ENV (program); +} +#undef FUNC_NAME + + +/* + * VM Frame + */ + +static long scm_vm_frame_tag; + +/* This is used for debugging */ +struct scm_vm_frame { + int size; + SCM program; + SCM variables; + SCM dynamic_link; + SCM stack_pointer; + SCM return_address; +}; + +#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ) +#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR)) +#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P) + +static SCM +make_vm_frame (SCM *fp) +{ + int i; + int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp)); + struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame"); + p->program = SCM_VM_FRAME_PROGRAM (fp); + p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp); + p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp); + p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp); + + if (!SCM_FALSEP (p->dynamic_link)) + p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link)); + + size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program); + p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); + for (i = 0; i < size; i++) + SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i); + + SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p); +} + +static SCM +mark_vm_frame (SCM frame) +{ + struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame); + scm_gc_mark (p->program); + scm_gc_mark (p->dynamic_link); + return p->variables; +} + +static void +init_vm_frame_type () +{ + scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0); + scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_frame_p +{ + return SCM_BOOL (SCM_VM_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_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->program; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_variables +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->variables; +} +#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_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->dynamic_link; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, + (SCM frame), +"") +#define FUNC_NAME s_scm_frame_stack_pointer +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->stack_pointer; +} +#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_VM_FRAME (1, frame); + return SCM_VM_FRAME_DATA (frame)->return_address; +} +#undef FUNC_NAME + + +/* + * VM Continuation + */ + +static long scm_vm_cont_tag; + +static SCM +capture_vm_cont (struct scm_vm *vmp) +{ + struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont"); + p->stack_size = vmp->stack_limit - vmp->sp; + p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM), + "capture_vm_cont"); + p->stack_limit = p->stack_base + p->stack_size - 1; + p->pc = vmp->pc; + p->sp = (SCM *) (vmp->stack_limit - vmp->sp); + p->fp = (SCM *) (vmp->stack_limit - vmp->fp); + memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM)); + SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p); +} + +static void +reinstate_vm_cont (struct scm_vm *vmp, SCM cont) +{ + struct scm_vm *p = SCM_VM_CONT_VMP (cont); + if (vmp->stack_size < p->stack_size) + { + puts ("FIXME: Need to expand"); + abort (); + } + vmp->pc = p->pc; + vmp->sp = vmp->stack_limit - (int) p->sp; + vmp->fp = vmp->stack_limit - (int) p->fp; + memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM)); +} + +static SCM +mark_vm_cont (SCM cont) +{ + SCM *p; + struct scm_vm *vmp = SCM_VM_CONT_VMP (cont); + for (p = vmp->stack_base; p <= vmp->stack_limit; p++) + if (SCM_NIMP (*p)) + scm_gc_mark (*p); + return SCM_BOOL_F; +} + +static scm_sizet +free_vm_cont (SCM cont) +{ + struct scm_vm *p = SCM_VM_CONT_VMP (cont); + int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM); + scm_must_free (p->stack_base); + scm_must_free (p); + return size; +} + +static void +init_vm_cont_type () +{ + scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0); + scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont); + scm_set_smob_free (scm_vm_cont_tag, free_vm_cont); +} + + +/* + * VM + */ + +static long scm_vm_tag; + +static SCM +make_vm (int stack_size) +{ + struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm"); + vmp->stack_size = stack_size; + vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm"); + vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1; + vmp->sp = vmp->stack_limit; + vmp->ac = SCM_BOOL_F; + vmp->pc = NULL; + vmp->fp = NULL; + vmp->options = SCM_EOL; + vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->next_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->call_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1)); + vmp->return_hook = scm_make_hook (SCM_MAKINUM (1)); + SCM_RETURN_NEWSMOB (scm_vm_tag, vmp); +} + +static SCM +mark_vm (SCM vm) +{ + SCM *p; + struct scm_vm *vmp = SCM_VM_DATA (vm); + for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) + if (SCM_NIMP (*p)) + scm_gc_mark (*p); + + scm_gc_mark (vmp->ac); + scm_gc_mark (vmp->boot_hook); + scm_gc_mark (vmp->halt_hook); + scm_gc_mark (vmp->next_hook); + scm_gc_mark (vmp->call_hook); + scm_gc_mark (vmp->apply_hook); + scm_gc_mark (vmp->return_hook); + return vmp->options; +} + +static void +init_vm_type () +{ + scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm)); + scm_set_smob_mark (scm_vm_tag, mark_vm); +} + +/* Scheme interface */ + +SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, + (), +"") +#define FUNC_NAME s_scm_vm_version +{ + return scm_makfrom0str (VERSION); +} +#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, + (), +"") +#define FUNC_NAME s_scm_make_vm +{ + return make_vm (VM_DEFAULT_STACK_SIZE); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_ac +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->ac; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_pc +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc); +} +#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_VM_MAKE_ADDRESS (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_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_current_frame +{ + SCM_VALIDATE_VM (1, vm); + return make_vm_frame (SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0, + (SCM vm, SCM addr), +"") +#define FUNC_NAME s_scm_vm_fetch_code +{ + SCM *p, list; + struct scm_instruction *inst; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_INUM (2, addr); + + p = SCM_VM_ADDRESS (addr); + + inst = find_instruction_by_code (*p); + if (!inst) + SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr)); + + list = SCM_LIST1 (scm_instruction_name (inst->obj)); + if (inst->type != INST_NONE) + { + if (inst->type == INST_ADDR) + { + p = SCM_CODE_TO_ADDR (p[1]); + SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p))); + } + else + SCM_SETCDR (list, SCM_LIST1 (p[1])); + } + return list; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_stack_to_list +{ + struct scm_vm *vmp; + SCM *p, list = SCM_EOL; + + SCM_VALIDATE_VM (1, vm); + + vmp = SCM_VM_DATA (vm); + for (p = vmp->sp + 1; p <= vmp->stack_limit; p++) + list = scm_cons (*p, list); + return list; +} +#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); + SCM_VALIDATE_SYMBOL (2, key); + return scm_assq_ref (SCM_VM_DATA (vm)->options, key); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0, + (SCM vm, SCM key, SCM val), +"") +#define FUNC_NAME s_scm_vm_set_option_x +{ + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_SYMBOL (2, key); + 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_boot_hook, "vm-boot-hook", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_boot_hook +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->next_hook; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0, + (SCM vm), +"") +#define FUNC_NAME s_scm_vm_call_hook +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->call_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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->apply_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 +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->return_hook; +} +#undef FUNC_NAME + +SCM_SYMBOL (sym_debug, "debug"); + +static SCM scm_regular_vm (SCM vm, SCM program); +static SCM scm_debug_vm (SCM vm, SCM program); + +#define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr) + +SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0, + (SCM vm, SCM program), +"") +#define FUNC_NAME s_scm_vm_run +{ + SCM bootcode; + static SCM template[5]; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + + if (SCM_EQ_P (template[0], SCM_PACK (0))) + { + template[0] = VM_CODE ("%loadc"); + template[1] = SCM_BOOL_F; + template[2] = VM_CODE ("%call"); + template[3] = SCM_MAKINUM (0); + template[4] = VM_CODE ("%halt"); + } + + /* Create a boot program */ + bootcode = make_bytecode (5); + memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5); + SCM_BYTECODE_BASE (bootcode)[1] = program; + SCM_BYTECODE_SIZE (bootcode) = 5; + SCM_BYTECODE_EXTS (bootcode) = NULL; + SCM_BYTECODE_NREQS (bootcode) = 0; + SCM_BYTECODE_RESTP (bootcode) = 0; + SCM_BYTECODE_NVARS (bootcode) = 0; + SCM_BYTECODE_NEXTS (bootcode) = 0; + program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F); + + if (SCM_FALSEP (scm_vm_option (vm, sym_debug))) + return scm_regular_vm (vm, program); + else + return scm_debug_vm (vm, program); +} +#undef FUNC_NAME + + +/* + * The VM engines + */ + +/* We don't want to snarf the engines */ +#ifndef SCM_MAGIC_SNARFER + +/* the regular engine */ +#define VM_ENGINE SCM_VM_REGULAR_ENGINE +#include "vm_engine.c" +#undef VM_ENGINE + +/* the debug engine */ +#define VM_ENGINE SCM_VM_DEBUG_ENGINE +#include "vm_engine.c" +#undef VM_ENGINE + +#endif /* not SCM_MAGIC_SNARFER */ + + +/* + * Initialize + */ + +static SCM scm_module_vm; + +void +scm_init_vm () +{ + SCM old_module; + + /* Initialize the module */ + scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)")); + old_module = scm_select_module (scm_module_vm); + + init_instruction_type (); + init_bytecode_type (); + init_program_type (); + init_vm_frame_type (); + init_vm_cont_type (); + init_vm_type (); + +#include "vm.x" + + scm_select_module (old_module); + + /* Initialize instruction tables */ + { + int i; + struct scm_instruction *p; + + SCM vm = make_vm (0); + scm_regular_vm (vm, SCM_BOOL_F); + scm_debug_vm (vm, SCM_BOOL_F); + + /* hash table */ + for (i = 0; i < INSTRUCTION_HASH_SIZE; i++) + scm_instruction_hash_table[i] = NULL; + + for (p = scm_regular_instruction_table; p->opcode != op_last; p++) + { + int hash; + struct inst_hash *data; + SCM inst = scm_permanent_object (make_instruction (p)); + p->obj = inst; + if (p->restp) p->type = INST_INUM; + hash = INSTRUCTION_HASH (p->addr); + data = scm_must_malloc (sizeof (*data), "inst_hash"); + data->addr = p->addr; + data->inst = p; + data->next = scm_instruction_hash_table[hash]; + scm_instruction_hash_table[hash] = data; + } + } +} + +void +scm_init_vm_vm_module () +{ + scm_register_module_xxx ("vm vm", (void *) scm_init_vm); +} diff --git a/src/vm.h b/src/vm.h new file mode 100644 index 000000000..dc493bf5d --- /dev/null +++ b/src/vm.h @@ -0,0 +1,226 @@ +/* Copyright (C) 2000 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_H +#define VM_H + +#include + + +/* + * Instruction + */ + +/* Opcode */ +enum scm_opcode { +#include "vm_system.op" +#include "vm_scheme.op" +#include "vm_number.op" + op_last +}; + +/* Argument type */ +/* Modify `mark_bytecode', `scm_make_bytecode', and `scm_bytecode_decode'! */ +enum scm_inst_type { + INST_NONE, /* no argument */ + INST_INUM, /* fixed integer */ + INST_SCM, /* scheme object */ + INST_EXT, /* external offset */ + INST_TOP, /* top-level variable */ + INST_CODE, /* program code */ + INST_ADDR /* program address */ +}; + +struct scm_instruction { + enum scm_opcode opcode; /* opcode */ + enum scm_inst_type type; /* argument type */ + char *name; /* instruction name */ + void *addr; /* instruction address */ + SCM obj; /* instruction object */ + /* fields for VM functions */ + char *sname; /* Scheme procedure name */ + char nargs; /* the number of arguments */ + char restp; /* have a rest argument or not */ +}; + +#define SCM_INSTRUCTION_P(OBJ) SCM_SMOB_PREDICATE (scm_instruction_tag, OBJ) +#define SCM_INSTRUCTION_DATA(INST) ((struct scm_instruction *) SCM_SMOB_DATA (INST)) +#define SCM_VALIDATE_INSTRUCTION(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, INSTRUCTION_P) + +#define SCM_SYSTEM_INSTRUCTION_P(OBJ) \ + (SCM_INSTRUCTION_P (OBJ) && !SCM_INSTRUCTION_DATA(OBJ)->sname) +#define SCM_FUNCTIONAL_INSTRUCTION_P(OBJ) \ + (SCM_INSTRUCTION_P (OBJ) && SCM_INSTRUCTION_DATA(OBJ)->sname) + +#define SCM_ADDR_TO_CODE(ADDR) SCM_PACK (ADDR) +#define SCM_CODE_TO_ADDR(CODE) ((void *) SCM_UNPACK (CODE)) +#define SCM_CODE_TO_DEBUG_ADDR(CODE) instruction_code_to_debug_addr (CODE) + + +/* + * Bytecode + */ + +struct scm_bytecode { + int size; /* the size of the bytecode */ + char nreqs; /* the number of required arguments */ + char restp; /* have a rest argument or not */ + char nvars; /* the number of local variables */ + char nexts; /* the number of external variables */ + int *exts; /* externalized arguments */ + SCM base[0]; /* base address (must be the last!) */ +}; + +#define SCM_BYTECODE_P(OBJ) SCM_SMOB_PREDICATE (scm_bytecode_tag, OBJ) +#define SCM_BYTECODE_DATA(BC) ((struct scm_bytecode *) SCM_SMOB_DATA (BC)) +#define SCM_VALIDATE_BYTECODE(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, BYTECODE_P) + +#define SCM_BYTECODE_SIZE(BC) SCM_BYTECODE_DATA (BC)->size +#define SCM_BYTECODE_NREQS(BC) SCM_BYTECODE_DATA (BC)->nreqs +#define SCM_BYTECODE_RESTP(BC) SCM_BYTECODE_DATA (BC)->restp +#define SCM_BYTECODE_NVARS(BC) SCM_BYTECODE_DATA (BC)->nvars +#define SCM_BYTECODE_NEXTS(BC) SCM_BYTECODE_DATA (BC)->nexts +#define SCM_BYTECODE_EXTS(BC) SCM_BYTECODE_DATA (BC)->exts +#define SCM_BYTECODE_BASE(BC) SCM_BYTECODE_DATA (BC)->base + +extern SCM scm_bytecode_p (SCM obj); +extern SCM scm_make_bytecode (SCM code); +extern SCM scm_bytecode_decode (SCM bytecode); + + +/* + * Program + */ + +#define SCM_MAKE_PROGRAM(CODE,ENV) make_program (CODE, ENV) +#define SCM_PROGRAM_P(OBJ) SCM_SMOB_PREDICATE (scm_program_tag, OBJ) +#define SCM_PROGRAM_CODE(PROG) SCM_CELL_OBJECT_1 (PROG) +#define SCM_PROGRAM_ENV(PROG) SCM_CELL_OBJECT_2 (PROG) +#define SCM_VALIDATE_PROGRAM(POS,PROG) SCM_MAKE_VALIDATE (POS, PROG, PROGRAM_P) + +/* Abbreviations */ +#define SCM_PROGRAM_SIZE(PROG) SCM_BYTECODE_SIZE (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NREQS(PROG) SCM_BYTECODE_NREQS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_RESTP(PROG) SCM_BYTECODE_RESTP (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NVARS(PROG) SCM_BYTECODE_NVARS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_NEXTS(PROG) SCM_BYTECODE_NEXTS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_EXTS(PROG) SCM_BYTECODE_EXTS (SCM_PROGRAM_CODE (PROG)) +#define SCM_PROGRAM_BASE(PROG) SCM_BYTECODE_BASE (SCM_PROGRAM_CODE (PROG)) + +extern SCM scm_program_p (SCM obj); +extern SCM scm_make_program (SCM bytecode, SCM env); +extern SCM scm_program_code (SCM program); +extern SCM scm_program_base (SCM program); + + +/* + * VM Address + */ + +#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR)) +#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ)) + + +/* + * VM External + */ + +/* VM external maintains a set of variables outside of the stack. + This is used to implement external chain of the environment. */ + +#define SCM_VM_MAKE_EXTERNAL(SIZE) scm_make_vector (SCM_MAKINUM ((SIZE) + 1), SCM_UNDEFINED) +#define SCM_VM_EXTERNAL_LINK(EXT) (SCM_VELTS (EXT)[0]) +#define SCM_VM_EXTERNAL_VARIABLE(EXT,N) (SCM_VELTS (EXT)[(N) + 1]) + + +/* + * VM Continuation + */ + +#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_cont_tag, OBJ) +#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT)) + +#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP) +#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT) + + +/* + * VM Frame + */ + +/* VM frame is allocated in the stack */ +/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */ +#define SCM_VM_FRAME_DATA_SIZE 5 +#define SCM_VM_FRAME_VARIABLE(FP,N) (FP[N]) +#define SCM_VM_FRAME_SIZE(FP) (FP[-1]) +#define SCM_VM_FRAME_PROGRAM(FP) (FP[-2]) +#define SCM_VM_FRAME_DYNAMIC_LINK(FP) (FP[-3]) +#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-4]) +#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-5]) + + +/* + * VM + */ + +/* Modify make_vm, mark_vm, and SYNC, too! */ +struct scm_vm { + SCM ac; /* Accumulator */ + SCM *pc; /* Program counter */ + SCM *sp; /* Stack pointer */ + SCM *fp; /* Frame pointer */ + int stack_size; + SCM *stack_base; + SCM *stack_limit; + SCM options; + SCM boot_hook, halt_hook, next_hook; + SCM call_hook, apply_hook, return_hook; +}; + +#define SCM_VM_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_tag, OBJ) +#define SCM_VM_DATA(VM) ((struct scm_vm *) SCM_SMOB_DATA (VM)) +#define SCM_VALIDATE_VM(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_P) + +/* Engine types */ +#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */ +#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */ + +#endif /* not VM_H */ diff --git a/src/vm_engine.c b/src/vm_engine.c new file mode 100644 index 000000000..2c6a1851c --- /dev/null +++ b/src/vm_engine.c @@ -0,0 +1,132 @@ +/* Copyright (C) 2000 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 two times! */ + +#include "vm_engine.h" + +/* VM names */ +#undef VM_NAME +#undef VM_TABLE +#if VM_ENGINE == SCM_VM_REGULAR_ENGINE +#define VM_NAME scm_regular_vm +#define VM_TABLE scm_regular_instruction_table +#else +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_NAME scm_debug_vm +#define VM_TABLE scm_debug_instruction_table +#endif +#endif + +static SCM +VM_NAME (SCM vm, SCM program) +#define FUNC_NAME "vm-engine" +{ + /* Copies of VM registers */ + SCM ac = SCM_PACK (0); + SCM *pc = NULL; + SCM *sp = NULL; + SCM *fp = NULL; + + /* Stack boundaries */ + SCM *stack_base = NULL; + SCM *stack_limit = NULL; + + /* Function arguments */ + int an = 0; + SCM a2 = SCM_PACK (0); + SCM a3 = SCM_PACK (0); + + /* Miscellaneous variables */ + SCM dynwinds = SCM_EOL; + struct scm_vm *vmp = NULL; + +#if VM_USE_HOOK + SCM hook_args = SCM_LIST1 (vm); +#endif + + /* Initialize the instruction table at the first time. + * This code must be here because the following table contains + * pointers to the labels defined in this function. */ + if (!VM_TABLE) + { + static struct scm_instruction table[] = { +#include "vm_system.vi" +#include "vm_scheme.vi" +#include "vm_number.vi" + { op_last } + }; + VM_TABLE = table; + return SCM_UNSPECIFIED; + } + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + + /* Initialize the VM */ + vmp = SCM_VM_DATA (vm); + vmp->pc = SCM_PROGRAM_BASE (program); + vmp->sp = vmp->stack_limit; + LOAD (); + + /* top frame */ + VM_NEW_FRAME (fp, program, SCM_BOOL_F, + SCM_VM_MAKE_ADDRESS (0), + SCM_VM_MAKE_ADDRESS (0)); + + /* Let's go! */ + VM_BOOT_HOOK (); + +#ifndef HAVE_LABELS_AS_VALUES + vm_start: switch (*pc++) { +#endif + +#include "vm_system.c" +#include "vm_scheme.c" +#include "vm_number.c" + +#ifndef HAVE_LABELS_AS_VALUES + } +#endif + + abort (); /* never reached */ +} +#undef FUNC_NAME diff --git a/src/vm_engine.h b/src/vm_engine.h new file mode 100644 index 000000000..19493b301 --- /dev/null +++ b/src/vm_engine.h @@ -0,0 +1,345 @@ +/* Copyright (C) 2000 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 Options + */ + +#undef VM_USE_BOOT_HOOK +#undef VM_USE_HALT_HOOK +#undef VM_USE_NEXT_HOOK +#undef VM_USE_CALL_HOOK +#undef VM_USE_APPLY_HOOK +#undef VM_USE_RETURN_HOOK +#undef VM_INIT_LOCAL_VARIABLES +#undef VM_CHECK_LINK +#undef VM_CHECK_BINDING +#undef VM_CHECK_PROGRAM_COUNTER + +#if VM_ENGINE == SCM_VM_REGULAR_ENGINE +#define VM_USE_BOOT_HOOK 0 +#define VM_USE_HALT_HOOK 0 +#define VM_USE_NEXT_HOOK 0 +#define VM_USE_CALL_HOOK 0 +#define VM_USE_APPLY_HOOK 0 +#define VM_USE_RETURN_HOOK 0 +#define VM_INIT_LOCAL_VARIABLES 0 +#define VM_CHECK_LINK 0 +#define VM_CHECK_BINDING 1 +#define VM_CHECK_PROGRAM_COUNTER 0 +#else +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_USE_BOOT_HOOK 1 +#define VM_USE_HALT_HOOK 1 +#define VM_USE_NEXT_HOOK 1 +#define VM_USE_CALL_HOOK 1 +#define VM_USE_APPLY_HOOK 1 +#define VM_USE_RETURN_HOOK 1 +#define VM_INIT_LOCAL_VARIABLES 1 +#define VM_CHECK_LINK 1 +#define VM_CHECK_BINDING 1 +#define VM_CHECK_PROGRAM_COUNTER 1 +#endif +#endif + +#undef VM_USE_HOOK +#if VM_USE_BOOT_HOOK || VM_USE_HALT_HOOK || VM_USE_NEXT_HOOK \ + || VM_USE_CALL_HOOK || VM_USE_APPLY_HOOK || VM_USE_RETURN_HOOK +#define VM_USE_HOOK 1 +#else +#define VM_USE_HOOK 0 +#endif + + +/* + * Type checking + */ + +#define VM_ASSERT_PROGRAM(OBJ) SCM_VALIDATE_PROGRAM (1, OBJ) + +#undef VM_ASSERT_BOUND +#if VM_CHECK_BINDING +#define VM_ASSERT_BOUND(CELL) \ + if (SCM_UNBNDP (SCM_CDR (CELL))) \ + SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CAR (CELL))) +#else +#define VM_ASSERT_BOUND(CELL) +#endif + +#undef VM_ASSERT_LINK +#if VM_CHECK_LINK +#define VM_ASSERT_LINK(OBJ) \ + if (SCM_FALSEP (OBJ)) \ + SCM_MISC_ERROR ("VM broken link", SCM_EOL) +#else +#define VM_ASSERT_LINK(OBJ) +#endif + + +/* + * Hooks + */ + +#undef VM_BOOT_HOOK +#if VM_USE_BOOT_HOOK +#define VM_BOOT_HOOK() SYNC (); scm_c_run_hook (vmp->boot_hook, hook_args) +#else +#define VM_BOOT_HOOK() +#endif + +#undef VM_HALT_HOOK +#if VM_USE_HALT_HOOK +#define VM_HALT_HOOK() SYNC (); scm_c_run_hook (vmp->halt_hook, hook_args) +#else +#define VM_HALT_HOOK() +#endif + +#undef VM_NEXT_HOOK +#if VM_USE_NEXT_HOOK +#define VM_NEXT_HOOK() SYNC (); scm_c_run_hook (vmp->next_hook, hook_args) +#else +#define VM_NEXT_HOOK() +#endif + +#undef VM_CALL_HOOK +#if VM_USE_CALL_HOOK +#define VM_CALL_HOOK() SYNC (); scm_c_run_hook (vmp->call_hook, hook_args) +#else +#define VM_CALL_HOOK() +#endif + +#undef VM_APPLY_HOOK +#if VM_USE_APPLY_HOOK +#define VM_APPLY_HOOK() SYNC (); scm_c_run_hook (vmp->apply_hook, hook_args) +#else +#define VM_APPLY_HOOK() +#endif + +#undef VM_RETURN_HOOK +#if VM_USE_RETURN_HOOK +#define VM_RETURN_HOOK() SYNC (); scm_c_run_hook (vmp->return_hook, hook_args) +#else +#define VM_RETURN_HOOK() +#endif + + +/* + * Basic operations + */ + +#define LOAD() \ +{ \ + ac = vmp->ac; \ + pc = vmp->pc; \ + sp = vmp->sp; \ + fp = vmp->fp; \ + stack_base = vmp->stack_base; \ + stack_limit = vmp->stack_limit; \ +} + +#define SYNC() \ +{ \ + vmp->ac = ac; \ + vmp->pc = pc; \ + vmp->sp = sp; \ + vmp->fp = fp; \ +} + +#define FETCH() *pc++ + +#define CONS(X,Y,Z) \ +{ \ + SCM cell; \ + SYNC (); \ + SCM_NEWCELL (cell); \ + SCM_SET_CELL_OBJECT_0 (cell, Y); \ + SCM_SET_CELL_OBJECT_1 (cell, Z); \ + X = cell; \ +} + +#define VM_SETUP_ARGS2() an = 2; a2 = ac; POP (ac); +#define VM_SETUP_ARGS3() an = 3; a3 = ac; POP (a2); POP (ac); +#define VM_SETUP_ARGS4() an = 4; a4 = ac; POP (a3); POP (a2); POP (ac); +#define VM_SETUP_ARGSN() an = SCM_INUM (FETCH ()); + + +/* + * Stack operation + */ + +#define PUSH(X) \ +{ \ + if (sp < stack_base) \ + SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ + *sp-- = (X); \ +} + +#define POP(X) \ +{ \ + if (sp == stack_limit) \ + SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \ + (X) = *++sp; \ +} + +#define POP_LIST(N,L) \ +{ \ + while (N-- > 0) \ + { \ + SCM obj; \ + POP (obj); \ + CONS (L, obj, L); \ + } \ +} + + +/* + * Frame allocation + */ + +/* an = the number of arguments */ +#define VM_SETUP_ARGS(PROG,NREQS,RESTP) \ +{ \ + if (RESTP) \ + /* have a rest argument */ \ + { \ + SCM list; \ + if (an < NREQS) \ + scm_wrong_num_args (PROG); \ + \ + /* Construct the rest argument list */ \ + an -= NREQS; /* the number of rest arguments */ \ + list = SCM_EOL; /* list of the rest arguments */ \ + POP_LIST (an, list); \ + PUSH (list); \ + } \ + else \ + /* not have a rest argument */ \ + { \ + if (an != NREQS) \ + scm_wrong_num_args (PROG); \ + } \ +} + +#define VM_EXPORT_ARGS(FP,PROG) \ +{ \ + int *exts = SCM_PROGRAM_EXTS (PROG); \ + if (exts) \ + { \ + int n = exts[0]; \ + while (n-- > 0) \ + SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (PROG), n) \ + = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \ + } \ +} + +#undef VM_FRAME_INIT_VARIABLES +#if VM_INIT_LOCAL_VARIABLES +/* This is necessary when creating frame objects for debugging */ +#define VM_FRAME_INIT_VARIABLES(FP,NVARS) \ +{ \ + int i; \ + for (i = 0; i < NVARS; i++) \ + SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \ +} +#else +#define VM_FRAME_INIT_VARIABLES(FP,NVARS) +#endif + +#define VM_NEW_FRAME(FP,PROG,DL,SP,RA) \ +{ \ + int nvars = SCM_PROGRAM_NVARS (PROG); /* the number of local vars */ \ + int nreqs = SCM_PROGRAM_NREQS (PROG); /* the number of required args */ \ + int restp = SCM_PROGRAM_RESTP (PROG); /* have a rest argument or not */ \ + \ + VM_SETUP_ARGS (PROG, nreqs, restp); \ + if (sp - nvars - SCM_VM_FRAME_DATA_SIZE < stack_base - 1) \ + SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \ + sp -= nvars + SCM_VM_FRAME_DATA_SIZE; \ + FP = sp + SCM_VM_FRAME_DATA_SIZE + 1; \ + SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \ + SCM_VM_FRAME_PROGRAM (FP) = PROG; \ + SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \ + SCM_VM_FRAME_STACK_POINTER (FP) = SP; \ + SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \ + VM_FRAME_INIT_VARIABLES (FP, nvars); \ + VM_EXPORT_ARGS (FP, PROG); \ +} + + +/* + * Goto next + */ + +#undef VM_PROGRAM_COUNTER_CHECK +#if VM_CHECK_PROGRAM_COUNTER +#define VM_PROGRAM_COUNTER_CHECK() \ +{ \ + SCM prog = SCM_VM_FRAME_PROGRAM (fp); \ + if (pc < SCM_PROGRAM_BASE (prog) \ + || pc >= (SCM_PROGRAM_BASE (prog) + SCM_PROGRAM_SIZE (prog))) \ + SCM_MISC_ERROR ("VM accessed invalid program address", SCM_EOL); \ +} +#else +#define VM_PROGRAM_COUNTER_CHECK() +#endif + +#undef VM_GOTO_NEXT +#if HAVE_LABELS_AS_VALUES +#if VM_ENGINE == SCM_VM_DEBUG_ENGINE +#define VM_GOTO_NEXT() goto *SCM_CODE_TO_DEBUG_ADDR (FETCH ()) +#else /* not SCM_VM_DEBUG_ENGINE */ +#define VM_GOTO_NEXT() goto *SCM_CODE_TO_ADDR (FETCH ()) +#endif +#else /* not HAVE_LABELS_AS_VALUES */ +#define VM_GOTO_NEXT() goto vm_start +#endif + +#define NEXT \ +{ \ + VM_PROGRAM_COUNTER_CHECK (); \ + VM_NEXT_HOOK (); \ + VM_GOTO_NEXT (); \ +} + +/* Just an abbreviation */ +#define RETURN(X) { ac = (X); NEXT; } diff --git a/src/vm_number.c b/src/vm_number.c new file mode 100644 index 000000000..7bf709215 --- /dev/null +++ b/src/vm_number.c @@ -0,0 +1,188 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0) +{ + if (SCM_INUMP (ac)) + RETURN (SCM_BOOL (SCM_EQ_P (ac, SCM_INUM0))); + RETURN (scm_zero_p (ac)); +} + +SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = SCM_INUM (ac) + 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_sum (ac, SCM_MAKINUM (1))); +} + +SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = SCM_INUM (ac) - 1; + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, SCM_MAKINUM (1))); +} + +SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_MAKINUM (0); + while (an-- > 0) + { + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + { + ac = SCM_MAKINUM (n); + continue; + } + } + ac = scm_sum (ac, a2); + } + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0) +{ + VM_SETUP_ARGS2 (); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_sum (ac, a2)); +} + +SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_MAKINUM (0); + while (an-- > 1) + { + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) + SCM_INUM (a2); + if (SCM_FIXABLE (n)) + { + ac = SCM_MAKINUM (n); + continue; + } + } + ac = scm_difference (ac, a2); + } + POP (a2); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (a2) - SCM_INUM (ac); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (a2, ac)); +} + +SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0) +{ + VM_SETUP_ARGS2 (); + if (SCM_INUMP (ac) && SCM_INUMP (a2)) + { + int n = SCM_INUM (ac) - SCM_INUM (a2); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, a2)); +} + +SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0) +{ + if (SCM_INUMP (ac)) + { + int n = - SCM_INUM (ac); + if (SCM_FIXABLE (n)) + RETURN (SCM_MAKINUM (n)); + } + RETURN (scm_difference (ac, SCM_UNDEFINED)); +} + +#define REL2(CREL,SREL) \ + VM_SETUP_ARGS2 (); \ + if (SCM_INUMP (ac) && SCM_INUMP (a2)) \ + RETURN (SCM_BOOL (SCM_INUM (ac) CREL SCM_INUM (a2))); \ + RETURN (SREL (ac, a2)) + +SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0) +{ + REL2 (<, scm_less_p); +} + +SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0) +{ + REL2 (>, scm_gr_p); +} + +SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0) +{ + REL2 (<=, scm_leq_p); +} + +SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0) +{ + REL2 (>=, scm_geq_p); +} + +SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0) +{ + REL2 (==, scm_num_eq_p); +} diff --git a/src/vm_scheme.c b/src/vm_scheme.c new file mode 100644 index 000000000..cfccbeda2 --- /dev/null +++ b/src/vm_scheme.c @@ -0,0 +1,111 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0) +{ + RETURN (SCM_BOOL (SCM_NULLP (ac))); +} + +SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0) +{ + VM_SETUP_ARGS2 (); + CONS (ac, ac, a2); + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + NEXT; +} + +SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0) +{ + SCM_VALIDATE_CONS (0, ac); + RETURN (SCM_CAR (ac)); +} + +SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0) +{ + SCM_VALIDATE_CONS (0, ac); + RETURN (SCM_CDR (ac)); +} + +SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0) +{ + RETURN (SCM_BOOL (SCM_FALSEP (ac))); +} + +SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + RETURN (scm_append (ac)); +} + +SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1) +{ + VM_SETUP_ARGSN (); + ac = SCM_EOL; + POP_LIST (an, ac); + RETURN (scm_append_x (ac)); +} + +SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0) +{ + VM_SETUP_ARGS3 (); + dynwinds = SCM_EOL; +} + +SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0) +{ + SYNC (); /* must sync all registers */ + PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */ + an = 1; /* the number of arguments */ + goto vm_call; +} diff --git a/src/vm_system.c b/src/vm_system.c new file mode 100644 index 000000000..f07e5af22 --- /dev/null +++ b/src/vm_system.c @@ -0,0 +1,549 @@ +/* Copyright (C) 2000 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 */ + +#include "vm-snarf.h" + +/* + * Variable access + */ + +#undef LOCAL_VAR +#define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET) + +#undef EXTERNAL_FOCUS +#define EXTERNAL_FOCUS(DEPTH) \ +{ \ + int depth = DEPTH; \ + env = SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)); \ + while (depth-- > 0) \ + { \ + VM_ASSERT_LINK (env); \ + env = SCM_VM_EXTERNAL_LINK (env); \ + } \ +} + +#undef EXTERNAL_VAR +#define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET) +#undef EXTERNAL_VAR0 +#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)), OFFSET) +#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp))), OFFSET) +#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)))), OFFSET) + +#undef TOPLEVEL_VAR +#define TOPLEVEL_VAR(CELL) SCM_CDR (CELL) +#undef TOPLEVEL_VAR_SET +#define TOPLEVEL_VAR_SET(CELL,OBJ) SCM_SETCDR (CELL, OBJ) + + +/* + * Basic operations + */ + +/* Must be the first instruction! */ +SCM_DEFINE_INSTRUCTION (nop, "%nop", INST_NONE) +{ + NEXT; +} + +SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE) +{ + SYNC (); + VM_HALT_HOOK (); + return ac; +} + + +/* + * %push family + */ + +SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE) +{ + PUSH (ac); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM) +{ + PUSH (FETCH ()); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl, "%pushl", INST_INUM) +{ + PUSH (LOCAL_VAR (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl_0, "%pushl:0", INST_NONE) +{ + PUSH (LOCAL_VAR (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE) +{ + PUSH (LOCAL_VAR (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM) +{ + PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE) +{ + PUSH (EXTERNAL_VAR0 (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE) +{ + PUSH (EXTERNAL_VAR0 (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM) +{ + PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE) +{ + PUSH (EXTERNAL_VAR1 (0)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE) +{ + PUSH (EXTERNAL_VAR1 (1)); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM) +{ + PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP) +{ + ac = FETCH (); + VM_ASSERT_BOUND (ac); + PUSH (TOPLEVEL_VAR (ac)); + NEXT; +} + + +/* + * %load family + */ + +SCM_DEFINE_INSTRUCTION (load_unspecified, "%load-unspecified", INST_NONE) +{ + RETURN (SCM_UNSPECIFIED); +} + +SCM_DEFINE_INSTRUCTION (loadc, "%loadc", INST_SCM) +{ + RETURN (FETCH ()); +} + +SCM_DEFINE_INSTRUCTION (loadl, "%loadl", INST_INUM) +{ + RETURN (LOCAL_VAR (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loadl_0, "%loadl:0", INST_NONE) +{ + RETURN (LOCAL_VAR (0)); +} + +SCM_DEFINE_INSTRUCTION (loadl_1, "%loadl:1", INST_NONE) +{ + RETURN (LOCAL_VAR (1)); +} + +SCM_DEFINE_INSTRUCTION (loade, "%loade", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + RETURN (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc)))); +} + +SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM) +{ + RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE) +{ + RETURN (EXTERNAL_VAR0 (0)); +} + +SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE) +{ + RETURN (EXTERNAL_VAR0 (1)); +} + +SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM) +{ + RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE) +{ + RETURN (EXTERNAL_VAR1 (0)); +} + +SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE) +{ + RETURN (EXTERNAL_VAR1 (1)); +} + +SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM) +{ + RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ()))); +} + +SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP) +{ + ac = FETCH (); + VM_ASSERT_BOUND (ac); + RETURN (TOPLEVEL_VAR (ac)); +} + + +/* + * %save family + */ + +SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM) +{ + LOCAL_VAR (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE) +{ + LOCAL_VAR (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE) +{ + LOCAL_VAR (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT) +{ + SCM env; + SCM loc = FETCH (); + EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc))); + EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM) +{ + EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE) +{ + EXTERNAL_VAR0 (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE) +{ + EXTERNAL_VAR0 (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1, "%savee:1", INST_INUM) +{ + EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1_0, "%savee:1:0", INST_NONE) +{ + EXTERNAL_VAR1 (0) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_1_1, "%savee:1:1", INST_NONE) +{ + EXTERNAL_VAR1 (1) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM) +{ + EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac; + NEXT; +} + +SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP) +{ + SCM cell = FETCH (); + scm_set_object_property_x (ac, scm_sym_name, SCM_CAR (cell)); + TOPLEVEL_VAR_SET (cell, ac); + NEXT; +} + + +/* + * branch and jump + */ + +SCM_DEFINE_INSTRUCTION (br_if, "%br-if", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (!SCM_FALSEP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (SCM_FALSEP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (SCM_NULLP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR) +{ + SCM addr = FETCH (); /* must always fetch */ + if (!SCM_NULLP (ac)) + pc = SCM_VM_ADDRESS (addr); + NEXT; +} + +SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR) +{ + pc = SCM_VM_ADDRESS (*pc); + NEXT; +} + + +/* + * Subprogram call + */ + +SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE) +{ + SYNC (); /* must be called before GC */ + RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_PROGRAM (fp))); +} + +/* Before: + ac = program + pc[0] = the number of arguments + + After: + pc = program's address +*/ +SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM) +{ + an = SCM_INUM (FETCH ()); /* the number of arguments */ + + vm_call: + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (ac)) + { + /* Create a new frame */ + SCM *last_fp = fp; + SCM *last_sp = sp + an; + VM_NEW_FRAME (fp, ac, + SCM_VM_MAKE_ADDRESS (last_fp), + SCM_VM_MAKE_ADDRESS (last_sp), + SCM_VM_MAKE_ADDRESS (pc)); + VM_CALL_HOOK (); + + /* Jump to the program */ + pc = SCM_PROGRAM_BASE (ac); + VM_APPLY_HOOK (); + NEXT; + } + /* + * Function call + */ + if (!SCM_FALSEP (scm_procedure_p (ac))) + { + /* Construct an argument list */ + SCM list = SCM_EOL; + POP_LIST (an, list); + RETURN (scm_apply (ac, list, SCM_EOL)); + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (ac)) + { + vm_call_cc: + /* Check the number of arguments */ + if (an != 1) + scm_wrong_num_args (ac); + + /* Reinstate the continuation */ + SCM_VM_REINSTATE_CONT (vmp, ac); + LOAD (); + POP (ac); /* return value */ + VM_RETURN_HOOK (); + NEXT; + } + + SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); +} + +/* Before: + ac = program + pc[0] = the number of arguments + + After: + pc = program's address +*/ +SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM) +{ + an = SCM_INUM (FETCH ()); /* the number of arguments */ + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (ac)) + { + if (SCM_EQ_P (ac, SCM_VM_FRAME_PROGRAM (fp))) + /* Tail recursive call */ + { + /* Setup arguments */ + int nvars = SCM_PROGRAM_NVARS (ac); /* the number of local vars */ + int nreqs = SCM_PROGRAM_NREQS (ac); /* the number of require args */ + int restp = SCM_PROGRAM_RESTP (ac); /* have a rest argument */ + VM_SETUP_ARGS (ac, nreqs, restp); + + /* Move arguments */ + nreqs += restp; + while (nreqs-- > 0) + { + SCM obj; + POP (obj); + SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj; + } + VM_EXPORT_ARGS (fp, ac); + } + else + /* Dynamic return call */ + { + /* Create a new frame */ + SCM *p = fp; + VM_NEW_FRAME (fp, ac, + SCM_VM_FRAME_DYNAMIC_LINK (p), + SCM_VM_FRAME_STACK_POINTER (p), + SCM_VM_FRAME_RETURN_ADDRESS (p)); + VM_CALL_HOOK (); + } + + /* Jump to the program */ + pc = SCM_PROGRAM_BASE (ac); + VM_APPLY_HOOK (); + NEXT; + } + /* + * Function call + */ + if (!SCM_FALSEP (scm_procedure_p (ac))) + { + /* Construct an argument list */ + SCM list = SCM_EOL; + POP_LIST (an, list); + ac = scm_apply (ac, list, SCM_EOL); + goto vm_return; + } + /* + * Continuation call + */ + if (SCM_VM_CONT_P (ac)) + goto vm_call_cc; + + SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac)); +} + +SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE) +{ + SCM *last_fp; + vm_return: + VM_RETURN_HOOK (); + last_fp = fp; + fp = SCM_VM_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (last_fp)); + sp = SCM_VM_ADDRESS (SCM_VM_FRAME_STACK_POINTER (last_fp)); + pc = SCM_VM_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (last_fp)); + NEXT; +} diff --git a/test/Makefile.am b/test/Makefile.am new file mode 100644 index 000000000..87daf1f15 --- /dev/null +++ b/test/Makefile.am @@ -0,0 +1,16 @@ +SOURCE_FILES = control.scm procedure.scm queens.scm +COMPILED_FILES = control.scc procedure.scc queens.scc +EXTRA_DIST = test.scm $(SOURCE_FILES) +CLEANFILES = $(COMPILED_FILES) +MAINTAINERCLEANFILES = Makefile.in + +GUILE = $(top_srcdir)/src/$(PACKAGE) + +test: $(COMPILED_FILES) + @for file in $(COMPILED_FILES); do \ + $(GUILE) -s test.scm $$file; \ + done + +SUFFIXES = .scm .scc +.scm.scc: + guile-compile $< diff --git a/test/control.scm b/test/control.scm new file mode 100644 index 000000000..2ae9ee78a --- /dev/null +++ b/test/control.scm @@ -0,0 +1,20 @@ + +(define income-tax + (lambda (income) + (cond + ((<= income 10000) + (* income .05)) + ((<= income 20000) + (+ (* (- income 10000) .08) + 500.00)) + ((<= income 30000) + (+ (* (- income 20000) .13) + 1300.00)) + (else + (+ (* (- income 30000) .21) + 2600.00))))) + +(test (income-tax 5000) 250.0) +(test (income-tax 15000) 900.0) +(test (income-tax 25000) 1950.0) +(test (income-tax 50000) 6800.0) diff --git a/test/procedure.scm b/test/procedure.scm new file mode 100644 index 000000000..5a25e59a9 --- /dev/null +++ b/test/procedure.scm @@ -0,0 +1,60 @@ +(define length + (lambda (ls) + (if (null? ls) + 0 + (+ (length (cdr ls)) 1)))) + +(test (length '()) 0) +(test (length '(a)) 1) +(test (length '(a b)) 2) + +(define remv + (lambda (x ls) + (cond + ((null? ls) '()) + ((eqv? (car ls) x) (remv x (cdr ls))) + (else (cons (car ls) (remv x (cdr ls))))))) + +(test (remv 'a '(a b b d)) '(b b d)) +(test (remv 'b '(a b b d)) '(a d)) +(test (remv 'c '(a b b d)) '(a b b d)) +(test (remv 'd '(a b b d)) '(a b b)) + +(define tree-copy + (lambda (tr) + (if (not (pair? tr)) + tr + (cons (tree-copy (car tr)) + (tree-copy (cdr tr)))))) + +(test (tree-copy '((a . b) . c)) '((a . b) . c)) + +(define quadratic-formula + (lambda (a b c) + (let ((root1 0) (root2 0) (minusb 0) (radical 0) (divisor 0)) + (set! minusb (- 0 b)) + (set! radical (sqrt (- (* b b) (* 4 (* a c))))) + (set! divisor (* 2 a)) + (set! root1 (/ (+ minusb radical) divisor)) + (set! root2 (/ (- minusb radical) divisor)) + (cons root1 root2)))) + +(test (quadratic-formula 2 -4 -6) '(3.0 . -1.0)) + +(define count + (let ((n 0)) + (lambda () + (set! n (1+ n)) + n))) + +(test (count) 1) +(test (count) 2) + +(define (fibonacci i) + (cond ((= i 0) 0) + ((= i 1) 1) + (else (+ (fibonacci (- i 1)) (fibonacci (- i 2)))))) + +(test (fibonacci 0) 0) +(test (fibonacci 5) 5) +(test (fibonacci 10) 55) diff --git a/test/queens.scm b/test/queens.scm new file mode 100644 index 000000000..66e8f0ce7 --- /dev/null +++ b/test/queens.scm @@ -0,0 +1,50 @@ +(define (filter predicate sequence) + (cond ((null? sequence) '()) + ((predicate (car sequence)) + (cons (car sequence) + (filter predicate (cdr sequence)))) + (else (filter predicate (cdr sequence))))) + +(define (accumulate op initial sequence) + (if (null? sequence) + initial + (op (car sequence) + (accumulate op initial (cdr sequence))))) + +(define (flatmap proc seq) + (accumulate append '() (map proc seq))) + +(define (enumerate-interval low high) + (if (> low high) + '() + (cons low (enumerate-interval (+ low 1) high)))) + +(define empty-board '()) + +(define (rest bs k rest-of-queens) + (map (lambda (new-row) + (adjoin-position new-row k rest-of-queens)) + (enumerate-interval 1 bs))) + +(define (queen-cols board-size k) + (if (= k 0) + (list empty-board) + (filter (lambda (positions) (safe? k positions)) + (flatmap (lambda (r) (rest board-size k r)) + (queen-cols board-size (- k 1)))))) + +(define (queens board-size) + (queen-cols board-size board-size)) + +(define (adjoin-position new-row k rest-of-queens) + (append rest-of-queens (list new-row))) + +(define (safe? k positions) + (let ((new (car (last-pair positions))) + (bottom (car positions))) + (cond ((= k 1) #t) + ((= new bottom) #f) + ((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f) + (else (safe? (- k 1) (cdr positions)))))) + +(test (queens 4) '((2 4 1 3) (3 1 4 2))) diff --git a/test/test.scm b/test/test.scm new file mode 100644 index 000000000..fd08af322 --- /dev/null +++ b/test/test.scm @@ -0,0 +1,12 @@ + +(set! %load-path (cons ".." %load-path)) +(use-modules (vm vm)) + +(define (test a b) + (if (equal? a b) + (display "OK\n") + (display "failed\n"))) + +(let ((file (cadr (command-line)))) + (format #t "Testing ~S...\n" file) + (load file)) diff --git a/vm/Makefile.am b/vm/Makefile.am new file mode 100644 index 000000000..91d1b37cd --- /dev/null +++ b/vm/Makefile.am @@ -0,0 +1,14 @@ +vmdatadir = $(datadir)/guile/vm +vmdata_DATA = utils.scm types.scm bytecomp.scm compile.scm shell.scm +noinst_DATA = libvm.so + +EXTRA_DIST = $(vmdata_DATA) +CLEANFILES = $(noinst_DATA) +MAINTAINERCLEANFILES = Makefile.in + +libvm.so: + $(LN_S) -f ../src/.libs/libguilevm.so ./libvm.so + +install-data-local: + rm -f $(vmdatadir)/libvm.so \ + && $(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so diff --git a/vm/bytecomp.scm b/vm/bytecomp.scm new file mode 100644 index 000000000..d46016b79 --- /dev/null +++ b/vm/bytecomp.scm @@ -0,0 +1,500 @@ +;;; bytecomp.scm --- convert an intermediate code to an assemble code + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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. +;; +;; Guile VM 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 Guile VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (vm bytecomp) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm types) + :export (byte-compile)) + +(define (byte-compile nreqs restp code) + (vector (byte-header nreqs restp (code-env code)) + (byte-finalize (byte-optimize (byte-translate code))))) + + +;;; +;;; Bytecode header +;;; + +(define (byte-header nreqs restp env) + (list->vector (cons* nreqs restp (env-header env)))) + + +;;; +;;; Bytecode translation +;;; + +(define (byte-translate code) + (let ((stack '())) + ;; push opcode + (define (push-code! . args) + (set! stack (cons args stack))) + (let trans ((code code) (use-stack #f) (tail #t)) + (let ((tag (code-tag code)) + (env (code-env code)) + (args (code-args code))) + ;;; + ;;; Utilities + ;;; + ;; push the result into the stack + (define (trans-use-stack code) (trans code #t #f)) + ;; just set the accumulator + (define (trans-non-stack code) (trans code #f #f)) + ;; code can be a tail position + (define (trans-tail code) (trans code #f tail)) + ;; set unspecified when a tail position + (define (unspecified-position) (if tail (push-code! '%load-unspecified))) + ;; return here when a tail position + (define (return-position) (if tail (push-code! '%return))) + ;; push the result into the stack + (define (push-position) (if use-stack (push-code! '%push))) + ;; return or push + (define (return-or-push) (return-position) (push-position)) + + ;;; + ;;; Translators + ;;; + (define (translate-unspecified) + ;; #:unspecified + ;; %load-unspecified + (push-code! '%load-unspecified) + (return-or-push)) + + (define (translate-constant obj) + ;; #:constant OBJ + ;; %pushc OBJ (if use-stack) + ;; %loadc OBJ (if non-stack) + (if use-stack + (push-code! '%pushc obj) + (push-code! '%loadc obj)) + (return-position)) + + (define (translate-local-var name var) + (let* ((offset (env-variable-address env var)) + (abbrev (string->symbol (format #f "~A:~A" name offset)))) + (if (instruction-name? abbrev) + (push-code! abbrev) + (push-code! name offset)))) + + (define (translate-external-var name var) + (let* ((addr (env-variable-address env var)) + (depth (car addr)) + (offset (cdr addr)) + (abbrev1 (string->symbol + (format #f "~A:~A" name depth))) + (abbrev2 (string->symbol + (format #f "~A:~A:~A" name depth offset)))) + (cond ((instruction-name? abbrev2) (push-code! abbrev2)) + ((instruction-name? abbrev1) (push-code! abbrev1 offset)) + (else (push-code! name addr))))) + + (define (translate-top-level-var name var) + (push-code! name (variable-name var))) + + (define (translate-local-ref var) + ;; #:ref # + ;; %pushl OFFSET (if use-stack) + ;; %loadl OFFSET (if non-stack) + (assert variable? var) + (translate-local-var (if use-stack '%pushl '%loadl) var) + (return-position)) + + (define (translate-external-ref var) + ;; #:ref # + ;; %pushe (DEPTH . OFFSET) (if use-stack) + ;; %loade (DEPTH . OFFSET) (if non-stack) + (assert variable? var) + (translate-external-var (if use-stack '%pushe '%loade) var) + (return-position)) + + (define (translate-top-level-ref var) + ;; #:ref # + ;; %pusht SYMBOL (if use-stack) + ;; %loadt SYMBOL (if non-stack) + (assert variable? var) + (translate-top-level-var (if use-stack '%pusht '%loadt) var) + (return-position)) + + (define (translate-local-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savel OFFSET + (assert variable? var) + (trans-non-stack obj) + (translate-local-var '%savel var) + (unspecified-position) + (return-or-push)) + + (define (translate-external-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savee (DEPTH . OFFSET) + (assert variable? var) + (trans-non-stack obj) + (translate-external-var '%savee var) + (unspecified-position) + (return-or-push)) + + (define (translate-top-level-set var obj) + ;; #:set # OBJ + ;; OBJ + ;; %savet SYMBOL + (assert variable? var) + (trans-non-stack obj) + (translate-top-level-var '%savet var) + (unspecified-position) + (return-or-push)) + + (define (translate-and . args) + ;; #:and ARG1 ARG2... + ;; ARG1 + ;; %br-if-not L0 + ;; ARG2 + ;; %br-if-not L0 + ;; ... + ;; L0: + (assert-for-each code? args) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if-not L0)) + args) + (push-code! #:label L0)) + (return-or-push)) + + (define (translate-or . args) + ;; #:or ARG1 ARG2... + ;; ARG1 + ;; %br-if L0 + ;; ARG2 + ;; %br-if L0 + ;; ... + ;; L0: + (assert-for-each code? args) + (let ((L0 (make-label))) + (for-each (lambda (arg) + (trans-non-stack arg) + (push-code! '%br-if L0)) + args) + (push-code! #:label L0)) + (return-or-push)) + + (define (translate-program nreqs restp code) + ;; #:make-program NREQS RESTP CODE + ;; %make-program BYTECODE + (push-code! '%make-program (byte-compile nreqs restp code)) + (return-or-push)) + + (define (translate-label label) + ;; #:label is processed by byte-finalize + (assert label? label) + (push-code! #:label label)) + + (define (translate-goto label) + ;; #:goto LABEL + ;; %jump ADDR (calculated in byte-finalize) + (assert label? label) + (push-code! '%jump label)) + + (define (translate-if test then else) + ;; #:if TEST THEN ELSE + ;; TEST + ;; %br-if-not L1 + ;; THEN (tail position) + ;; %jump L2 (if not tail) + ;; L1: ELSE (tail position) + ;; L2: + (assert code? test) + (assert code? then) + (assert code? else) + (let ((L1 (make-label)) + (L2 (make-label))) + (trans-non-stack test) + (push-code! '%br-if-not L1) + (trans-tail then) + (if (not tail) + (push-code! '%jump L2)) + (push-code! #:label L1) + (trans-tail else) + (push-code! #:label L2)) + (push-position)) + + (define (translate-until test . body) + ;; #:until TEST BODY... + ;; L0: TEST + ;; %br-if L1 + ;; BODY... + ;; %jump L0 + ;; L1: + (assert code? test) + (assert-for-each code? body) + (let ((L0 (make-label)) + (L1 (make-label))) + (push-code! #:label L0) + (trans-non-stack test) + (push-code! '%br-if L1) + (for-each trans-non-stack body) + (push-code! '%jump L0) + (push-code! #:label L1)) + (unspecified-position) + (return-position)) + + (define (translate-begin . body) + ;; #:begin BODY... TAIL + ;; BODY... + ;; TAIL (tail position) + (assert-for-each code? body) + (let* ((list (reverse body)) + (tail (car list)) + (body (reverse! (cdr list)))) + (for-each trans-non-stack body) + (trans-tail tail)) + (push-position)) + + (define (translate-regular-call code . args) + ;; #:call CODE ARGS... + ;; ARGS... (-> stack) + ;; CODE + ;; %(tail-)call NARGS + (let ((nargs (length args))) + (for-each trans-use-stack args) + (trans-non-stack code) + (if tail + (push-code! '%tail-call nargs) + (push-code! '%call nargs))) + (push-position)) + + (define (translate-function-call inst . args) + ;; #:call INST ARGS... + (let ((name (instruction-name inst)) + (nargs (length args))) + (cond + ((cadr (instruction-arity inst)) + ;; ARGS... (-> stack) + ;; INST NARGS + (for-each trans-use-stack args) + (push-code! name nargs)) + (else + (case nargs + ((0) + ;; INST + (push-code! name)) + ((1) + ;; ARG1 + ;; INST + (trans-non-stack (car args)) + (push-code! name)) + ((2) + ;; ARG1 (-> stack) + ;; ARG2 + ;; INST + (trans-use-stack (car args)) + (trans-non-stack (cadr args)) + (push-code! name)) + ((3) + ;; ARG1 (-> stack) + ;; ARG2 (-> stack) + ;; ARG3 + ;; INST + (trans-use-stack (car args)) + (trans-use-stack (cadr args)) + (trans-non-stack (caddr args)) + (push-code! name)))))) + (return-or-push)) + + (define (translate-call obj . args) + (assert-for-each code? args) + (if (variable? obj) + (if (eq? (variable-type obj) 'function) + (cond + ((and (variable-bound? obj) + (and-let* ((obj (variable-value obj)) + (def (assq-ref *vm-function-table* obj))) + (or (list-ref def (min (length args) 4)) + (error "Wrong number of arguments")))) + => (lambda (inst) + (apply translate-function-call inst args))) + ((top-level-variable? obj) + (apply translate-regular-call + (make-code #:ref env obj) args))) + (apply translate-regular-call + (make-code #:ref env obj) args)) + (apply translate-regular-call obj args))) + + ;;; + ;;; Dispatch + ;;; + (case tag + ((#:unspecified) + ;; #:unspecified + (check-nargs args = 0) + (translate-unspecified)) + ((#:constant) + ;; #:constant OBJ + (check-nargs args = 1) + (translate-constant (car args))) + ((#:ref) + ;; #:ref VAR + (check-nargs args = 1) + (let ((var (car args))) + (cond + ((local-variable? var) (translate-local-ref var)) + ((external-variable? var) (translate-external-ref var)) + ((top-level-variable? var) (translate-top-level-ref var))))) + ((#:set) + ;; #:set VAR OBJ + (check-nargs args = 2) + (let ((var (car args)) (obj (cadr args))) + (cond + ((local-variable? var) (translate-local-set var obj)) + ((external-variable? var) (translate-external-set var obj)) + ((top-level-variable? var) (translate-top-level-set var obj))))) + ((#:and) + ;; #:and ARGS... + (apply translate-and args)) + ((#:or) + ;; #:or ARGS... + (apply translate-or args)) + ((#:make-program) + ;; #:make-program NREQS RESTP CODE + (check-nargs args = 3) + (translate-program (car args) (cadr args) (caddr args))) + ((#:label) + ;; #:label LABEL + (check-nargs args = 1) + (translate-label (car args))) + ((#:goto) + ;; #:goto LABEL + (check-nargs args = 1) + (translate-goto (car args))) + ((#:if) + ;; #:if TEST THEN ELSE + (check-nargs args = 3) + (translate-if (car args) (cadr args) (caddr args))) + ((#:until) + ;; #:until TEST BODY... + (check-nargs args >= 2) + (apply translate-until (car args) (cdr args))) + ((#:begin) + ;; #:begin BODY... + (check-nargs args >= 1) + (apply translate-begin args)) + ((#:call) + ;; #:call OBJ ARGS... + (check-nargs args >= 1) + (apply translate-call (car args) (cdr args))) + (else + (error "Unknown tag:" tag))))) + ;; that's it for this stage + (reverse! stack))) + + +;;; +;;; Bytecode optimization +;;; + +(define (byte-optimize code) + (let loop ((last (car code)) (code (cdr code)) (result '())) + (define (continue) (loop (car code) (cdr code) (cons last result))) + (if (null? code) + (reverse! (cons last result)) + (let ((this (car code))) + (case (car this) + ((%br-if) + (case (car last) + ((null?) + (loop (cons '%br-if-null (cdr this)) (cdr code) result)) + (else + (continue)))) + ((%br-if-not) + (case (car last) + ((null?) + (loop (cons '%br-if-not-null (cdr this)) (cdr code) result)) + (else + (continue)))) + (else + (continue))))))) + + +;;; +;;; Bytecode finalization +;;; + +(define (byte-finalize code) + (let loop ((code code) (result '())) + (cond + ((null? code) + ;; Return the final assemble code + (let ((finalize (lambda (obj) + (if (label? obj) + (label-position obj) + obj)))) + (list->vector (reverse! (map finalize result))))) + ((eq? (caar code) #:label) + ;; Calculate the label position + (set! (label-position (cadar code)) (length result)) + (loop (cdr code) result)) + (else + ;; Append to the result + (loop (cdr code) (append! (reverse! (car code)) result)))))) + + +;;; +;;; Function table +;;; + +(define (functional-instruction-alist) + (let ((alist '())) + (define (add! name inst) + (let ((pair (assq name alist))) + (if pair + (set-cdr! pair (cons inst (cdr pair))) + (set! alist (acons name (list inst) alist))))) + (for-each (lambda (inst) + (and-let* ((name (instruction-scheme-name inst))) + (add! name inst))) + (instruction-list)) + alist)) + +(define (build-table-data pair) + (let ((name (car pair)) (insts (cdr pair))) + (let ((vec (make-vector 5 #f))) + (define (build-data! inst) + (let ((arity (instruction-arity inst))) + (let ((nargs (car arity)) + (restp (cadr arity))) + (if restp + (do ((i nargs (1+ i))) + ((>= i 4) + (vector-set! vec 4 inst)) + (if (not (vector-ref vec i)) + (vector-set! vec i inst))) + (vector-set! vec nargs inst))))) + (for-each build-data! insts) + (let ((func (eval name (interaction-environment)))) + (cons func (vector->list vec)))))) + +(define *vm-function-table* + (map build-table-data (functional-instruction-alist))) + +;;; bytecomp.scm ends here diff --git a/vm/compile.scm b/vm/compile.scm new file mode 100644 index 000000000..14d25a490 --- /dev/null +++ b/vm/compile.scm @@ -0,0 +1,310 @@ +;;; compile.scm --- Compile Scheme codes + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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. +;; +;; Guile VM 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 Guile VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (vm compile) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm types) + :use-module (vm bytecomp) + :use-module (ice-9 syncase) + :export (compile compile-file)) + +(define (compile form . opts) + (catch 'result + (lambda () + (let ((x (syncase form))) + (if (or (memq #:e opts) (memq #:expand-only opts)) + (throw 'result x)) + (set! x (parse x (make-env '() (make-top-level-env)))) + (if (or (memq #:p opts) (memq #:parse-only opts)) + (throw 'result x)) + (set! x (byte-compile 0 #f x)) + (if (or (memq #:c opts) (memq #:compile-only opts)) + (throw 'result x)) + (make-program (make-bytecode x) #f))) + (lambda (key arg) arg))) + +(define (compile-file file) + (let ((out-file (string-append (substring file 0 (1- (string-length file))) + "c"))) + (with-input-from-file file + (lambda () + (with-output-to-file out-file + (lambda () + (format #t ";;; Compiled from ~A\n\n" file) + (display "(let ((vm (make-vm)))\n") + (display " (define (vm-exec code)\n") + (display " (vm-run vm (make-program (make-bytecode code) #f)))\n") + (do ((input (read) (read))) + ((eof-object? input)) + (display "(vm-exec ") + (write (compile input #:compile-only)) + (display ")\n")) + (display ")\n"))))))) + + +;;; +;;; Parser +;;; + +(define (parse x env) + (cond ((pair? x) (parse-pair x env)) + ((symbol? x) (make-code:ref env (env-ref env x))) + (else (make-code:constant env x)))) + +(define (parse-pair x env) + (let ((name (car x)) (args (cdr x))) + (if (assq name *syntax-alist*) + ;; syntax + ((assq-ref *syntax-alist* name) args env) + ;; procedure + (let ((proc (if (symbol? name) + (env-ref env name) + (parse name env)))) + (if (and (variable? proc) + (variable-bound? proc) + (assq (variable-value proc) *procedure-alist*)) + ;; procedure macro + ((assq-ref *procedure-alist* (variable-value proc)) args env) + ;; procedure call + (apply make-code:call env proc (map-parse args env))))))) + +(define (map-parse x env) + (map (lambda (x) (parse x env)) x)) + + +;;; +;;; Syntax +;;; + +(define *syntax-list* + '(quote lambda set! define if cond and or begin let let* letrec + local-set! until)) + +(define (parse-quote args env) + (make-code:constant env (car args))) + +(define (canon-formals formals) + ;; foo -> (() . foo) + ;; (foo bar baz) -> ((foo bar baz) . #f) + ;; (foo bar . baz) -> ((foo bar) . baz) + (cond ((symbol? formals) + (cons '() formals)) + ((or (null? formals) + (null? (cdr (last-pair formals)))) + (cons formals #f)) + (else + (let* ((copy (list-copy formals)) + (pair (last-pair copy)) + (last (cdr pair))) + (set-cdr! pair '()) + (cons copy last))))) + +(define (parse-lambda args env) + (let ((formals (car args)) (body (cdr args))) + (let* ((pair (canon-formals formals)) + (reqs (car pair)) + (rest (cdr pair)) + (syms (append reqs (if rest (list rest) '()))) + (new-env (make-env syms env))) + (make-code:program env (length reqs) (if rest #t #f) + (parse-begin body new-env))))) + +(define (parse-set! args env) + (let ((var (env-ref env (car args))) + (val (parse (cadr args) env))) + (variable-externalize! var) + (make-code:set env var val))) + +(define (parse-local-set! args env) + (let ((var (env-ref env (car args))) + (val (parse (cadr args) env))) + (make-code:set env var val))) + +(define (parse-define args env) + (parse-set! args env)) + +(define (parse-if args env) + (let ((test (parse (car args) env)) + (consequent (parse (cadr args) env)) + (alternate (if (null? (cddr args)) + (make-code:unspecified env) + (parse (caddr args) env)))) + (make-code:if env test consequent alternate))) + +;; FIXME: This should be expanded by syncase. +(define (parse-cond args env) + (cond ((null? args) (make-code:unspecified env)) + ((eq? (caar args) 'else) + (parse-begin (cdar args) env)) + (else + (let* ((clause (car args)) + (test (parse (car clause) env)) + (body (parse-begin (cdr clause) env)) + (alternate (parse-cond (cdr args) env))) + (make-code:if env test body alternate))))) + +(define (parse-and args env) + (apply make-code:and env (map-parse args env))) + +(define (parse-or args env) + (apply make-code:or env (map-parse args env))) + +(define (parse-begin args env) + (apply make-code:begin env (map-parse args env))) + +(define (%parse-let:finish env bindings init body) + (for-each (lambda (binding) + (env-remove-variable! env (car binding))) + bindings) + (apply make-code:begin env (append! init body))) + +(define (parse-let args env) + (if (symbol? (car args)) + ;; named let + (let ((tag (car args)) (bindings (cadr args)) (body (cddr args))) + (let* ((var (env-add-variable! env tag)) + (proc (parse-lambda (cons (map car bindings) body) env)) + (init (make-code:set env var proc)) + (call (apply make-code:call env var + (map-parse (map cadr bindings) env)))) + (env-remove-variable! env tag) + (make-code:begin env init call))) + ;; normal let + (let ((bindings (car args)) (body (cdr args))) + (let* (;; create values before binding + (vals (map-parse (map cadr bindings) env)) + ;; create bindings + (init (map (lambda (sym val) + (let ((var (env-add-variable! env sym))) + (make-code:set env var val))) + (map car bindings) vals))) + (%parse-let:finish env bindings init (map-parse body env)))))) + +(define (parse-let* args env) + (let ((bindings (car args)) (body (cdr args))) + (let (;; create values and bindings one after another + (init (map (lambda (binding) + (let* ((val (parse (cadr binding) env)) + (var (env-add-variable! env (car binding)))) + (make-code:set env var val))) + bindings))) + (%parse-let:finish env bindings init (map-parse body env))))) + +(define (parse-letrec args env) + (let ((bindings (car args)) (body (cdr args))) + (let* (;; create all variables before values + (vars (map (lambda (sym) + (env-add-variable! env sym)) + (map car bindings))) + ;; create and set values + (init (map (lambda (var val) + (make-code:set env var (parse val env))) + vars (map cadr bindings)))) + (%parse-let:finish env bindings init (map-parse body env))))) + +(define (parse-until args env) + (apply make-code:until env (parse (car args) env) + (map-parse (cdr args) env))) + +(define *syntax-alist* + (map (lambda (name) + (cons name (eval (symbol-append 'parse- name) (current-module)))) + *syntax-list*)) + + +;;; +;;; Procedure +;;; + +(define *procedure-list* + '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + map for-each)) + +(define (parse-caar args env) (parse `(car (car ,@args)) env)) +(define (parse-cadr args env) (parse `(car (cdr ,@args)) env)) +(define (parse-cdar args env) (parse `(cdr (car ,@args)) env)) +(define (parse-cddr args env) (parse `(cdr (cdr ,@args)) env)) + +(define (parse-caaar args env) (parse `(car (car (car ,@args))) env)) +(define (parse-caadr args env) (parse `(car (car (cdr ,@args))) env)) +(define (parse-cadar args env) (parse `(car (cdr (car ,@args))) env)) +(define (parse-caddr args env) (parse `(car (cdr (cdr ,@args))) env)) +(define (parse-cdaar args env) (parse `(cdr (car (car ,@args))) env)) +(define (parse-cdadr args env) (parse `(cdr (car (cdr ,@args))) env)) +(define (parse-cddar args env) (parse `(cdr (cdr (car ,@args))) env)) +(define (parse-cdddr args env) (parse `(cdr (cdr (cdr ,@args))) env)) + +(define (parse-caaaar args env) (parse `(car (car (car (car ,@args)))) env)) +(define (parse-caaadr args env) (parse `(car (car (car (cdr ,@args)))) env)) +(define (parse-caadar args env) (parse `(car (car (cdr (car ,@args)))) env)) +(define (parse-caaddr args env) (parse `(car (car (cdr (cdr ,@args)))) env)) +(define (parse-cadaar args env) (parse `(car (cdr (car (car ,@args)))) env)) +(define (parse-cadadr args env) (parse `(car (cdr (car (cdr ,@args)))) env)) +(define (parse-caddar args env) (parse `(car (cdr (cdr (car ,@args)))) env)) +(define (parse-cadddr args env) (parse `(car (cdr (cdr (cdr ,@args)))) env)) +(define (parse-cdaaar args env) (parse `(cdr (car (car (car ,@args)))) env)) +(define (parse-cdaadr args env) (parse `(cdr (car (car (cdr ,@args)))) env)) +(define (parse-cdadar args env) (parse `(cdr (car (cdr (car ,@args)))) env)) +(define (parse-cdaddr args env) (parse `(cdr (car (cdr (cdr ,@args)))) env)) +(define (parse-cddaar args env) (parse `(cdr (cdr (car (car ,@args)))) env)) +(define (parse-cddadr args env) (parse `(cdr (cdr (car (cdr ,@args)))) env)) +(define (parse-cdddar args env) (parse `(cdr (cdr (cdr (car ,@args)))) env)) +(define (parse-cddddr args env) (parse `(cdr (cdr (cdr (cdr ,@args)))) env)) + +(define (parse-map args env) + (check-nargs args >= 2) + (case (length args) + ((2) + (let ((proc (car args)) (list (cadr args))) + (parse `(let ((list ,list) (result '())) + (until (null? list) + (local-set! result (cons (,proc (car list)) result)) + (local-set! list (cdr list))) + (reverse! result)) + env))) + (else + (error "Not implemented yet")))) + +(define (parse-for-each args env) + (check-nargs args >= 2) + (case (length args) + ((2) + (let ((proc (car args)) (list (cadr args))) + (parse `(let ((list ,list)) + (until (null? list) + (,proc (car list)) + (local-set! list (cdr list)))) + env))) + (else + (error "Not implemented yet")))) + +(define *procedure-alist* + (map (lambda (name) + (cons (eval name (current-module)) + (eval (symbol-append 'parse- name) (current-module)))) + *procedure-list*)) + +;;; compile.scm ends here diff --git a/vm/shell.scm b/vm/shell.scm new file mode 100644 index 000000000..375fe82af --- /dev/null +++ b/vm/shell.scm @@ -0,0 +1,221 @@ +;;; shell.scm --- interactive VM operations + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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. +;; +;; Guile VM 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 Guile VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (vm shell) + :use-module (vm vm) + :use-module (vm utils) + :use-module (vm compile) + :use-module (ice-9 format)) + +;;; +;;; VM Shell +;;; + +(define *vm-default-prompt* "VM> ") + +(define *vm-boot-message* "\ +Copyright (C) 2000 Free Software Foundation, Inc. +Guile VM is free software, covered by the GNU General Public License, +and you are welcome to change it and/or distribute copies of it under +certain conditions. There is absolutely no warranty for Guile VM.\n") + +(define (vm-init vm) + (vm-set-option! vm 'prompt *vm-default-prompt*) + (vm-set-option! vm 'verbose #f) + (vm-set-option! vm 'history-count 1)) + +(define-public (vm-boot vm) + (format #t "Guile Virtual Machine ~A\n" (vm-version)) + (display *vm-boot-message*) + (display "\nType \"help\" for information\n") + (vm-shell vm)) + +(define-public (vm-shell vm) + (vm-init vm) + (let ((read-expr (lambda () (read (current-input-port))))) + (let loop () + (display (or (vm-option vm 'prompt) *vm-default-prompt*)) + (let ((cmd (read-expr))) + (if (not (eof-object? cmd)) + (case cmd + ((eval) (vm-eval vm (read-expr)) (loop)) + ((trace) (vm-trace vm (read-expr)) (loop)) + ((parse) (vm-parse vm (read-expr)) (loop)) + ((compile) (vm-compile vm (read-expr)) (loop)) + ((set) (vm-set-option! vm (read-expr) (read-expr)) (loop)) + (else + (error "Unknown command: ~S" cmd)))))))) + +(define-public (vm-repl vm) + (vm-init vm) + (let loop () + (display (or (vm-option vm 'prompt) *vm-default-prompt*)) + (let ((form (read (current-input-port)))) + (if (not (eof-object? form)) + (begin + (vm-eval vm form) + (loop)))))) + +(define (vm-eval vm form) + (let ((result (vm-run vm (compile form)))) + (if (not (eq? result *unspecified*)) + (let* ((n (or (vm-option vm 'history-count) 1)) + (var (symbol-append "$" (number->string n)))) + (intern-symbol #f var) + (symbol-set! #f var result) + (format #t "~A = ~S\n" var result) + (vm-set-option! vm 'history-count (1+ n)) + result)))) + +(define (vm-parse vm form) + (parse form (make-top-level-env))) + +(define (vm-compile vm form) + #f) + + +;;; +;;; Step +;;; + +(define (vm-step-boot vm) + (format #t "VM: Starting a program ~S:~%" + (frame-program (vm-current-frame vm)))) + +(define (vm-step-halt vm) + (display "VM: Program terminated with the return value: ") + (display (vm:ac vm)) + (newline)) + +(define (vm-step-next vm) + (if (vm-option vm 'verbose) + (let ((frame (vm-current-frame vm))) + (display "--------------------------------------------------\n") + (format #t "PC = 0x~X SP = 0x~X FP = 0x~X AC = ~S~%" + (vm:pc vm) (vm:sp vm) (vm:fp vm) (vm:ac vm)) + (do ((frame frame (frame-dynamic-link frame)) + (frames '() (cons frame frames))) + ((not frame) + (for-each (lambda (frame) + (format #t "Frame = [~S 0x~X 0x~X]~%" + (frame-program frame) + (frame-stack-pointer frame) + (frame-return-address frame))) + frames))) + (format #t "Local variables = ~S~%" (frame-variables frame)) + (format #t "External variables = ~S~%" (program-external (frame-program frame))) + (format #t "Stack = ~S~%" (vm-stack->list vm)))) + (format #t "0x~X:" (vm:pc vm)) + (for-each (lambda (obj) (display " ") (write obj)) + (vm-fetch-code vm (vm:pc vm))) + (newline)) + +(define-public (vm-step vm form . opts) + (let ((debug-flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (add-hook! (vm-boot-hook vm) vm-step-boot) + (add-hook! (vm-halt-hook vm) vm-step-halt) + (add-hook! (vm-next-hook vm) vm-step-next) + (vm-set-option! vm 'debug #t)) + (lambda () + (if (pair? opts) + (vm-set-option! vm 'verbose #t)) + (vm-run vm (compile form))) + (lambda () + (remove-hook! (vm-boot-hook vm) vm-step-boot) + (remove-hook! (vm-halt-hook vm) vm-step-halt) + (remove-hook! (vm-next-hook vm) vm-step-next) + (vm-set-option! vm 'debug debug-flag))))) + + +;;; +;;; Trace +;;; + +(define (vm-trace-prefix frame) + (and-let* ((link (frame-dynamic-link frame))) + (display "| ") + (vm-trace-prefix link))) + +(define (vm-frame->call frame) + (define (truncate! list n) + (let loop ((list list) (n n)) + (if (<= n 1) + (set-cdr! list '()) + (loop (cdr list) (1- n)))) + list) + (let* ((prog (frame-program frame)) + (name (or (program-name prog) prog))) + (cons name (reverse! (vector->list (frame-variables frame)))))) + +(define (vm-trace-apply vm) + (let ((frame (vm-current-frame vm))) + (vm-trace-prefix frame) + (display (vm-frame->call frame)) + (newline))) + +(define (vm-trace-return vm) + (vm-trace-prefix (vm-current-frame vm)) + (display (vm:ac vm)) + (newline)) + +(define-public (vm-trace vm form) + (let ((debug-flag (vm-option vm 'debug))) + (dynamic-wind + (lambda () + (add-hook! (vm-apply-hook vm) vm-trace-apply) + (add-hook! (vm-return-hook vm) vm-trace-return) + (vm-set-option! vm 'debug #t)) + (lambda () + (vm-run vm (compile form))) + (lambda () + (remove-hook! (vm-apply-hook vm) vm-trace-apply) + (remove-hook! (vm-return-hook vm) vm-trace-return) + (vm-set-option! vm 'debug debug-flag))))) + + +;;; +;;; Disassemble +;;; + +(define-public (disassemble program) + (format #t "Program at ~X:" (program-base program)) + (let ((subprogs '()) + (list (vector->list (bytecode-decode (program-code program))))) + (for-each (lambda (obj) + (cond ((opcode? obj) + (newline) + (display obj)) + ((program? obj) + (set! subprogs (cons subprogs obj)) + (display " ") + (display obj)) + (else + (display " ") + (display obj)))) + list) + (newline) + (for-each disassemble (reverse! subprogs)))) + +;;; shell.scm ends here diff --git a/vm/types.scm b/vm/types.scm new file mode 100644 index 000000000..cc8c4aff8 --- /dev/null +++ b/vm/types.scm @@ -0,0 +1,367 @@ +;;; types.scm --- data types used in the compiler and assembler + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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. +;; +;; Guile VM 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 Guile VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (vm types) + :use-module (vm vm) + :use-module (vm utils) + :use-module (oop goops)) + + +;;; +;;; VM code +;;; + +(define-class () + (tag #:accessor code-tag #:init-keyword #:tag) + (env #:accessor code-env #:init-keyword #:env) + (args #:accessor code-args #:init-keyword #:args) + (type #:accessor code-type #:init-value #f)) + +(export code-tag code-env code-args code-type) + +(define-method (write (obj ) port) + (display "#symbol (code-tag obj))) + (map (lambda (obj) (display " ") (write obj port)) + (code-args obj)) + (display ">")) + +(define-public (code? obj) + (is-a? obj )) + +(define-public (make-code tag env . args) + (make #:tag tag #:env env #:args args)) + + +;;; +;;; VM label +;;; + +(define-class () + (pos #:accessor label-position)) + +(export label-position) + +(define-public (label? obj) + (is-a? obj )) + +(define-public (make-label) + (make )) + + +;;; +;;; VM location +;;; + +(define-class ()) + +(define (make-location) + (make )) + + +;;; +;;; VM variable +;;; + +(define-class () + (name #:accessor variable-name #:init-keyword #:name) + (type #:accessor variable-type #:init-value #f) + (value #:accessor variable-value) + (loc #:accessor variable-location #:init-keyword #:location) + (count #:accessor variable-count #:init-value 0)) + +(define-class ()) +(define-class ()) +(define-class ()) + +(export variable-name variable-type variable-value variable-count) + +(define-method (write (obj ) port) + (display "#") + (display (class-name (class-of obj))) + (display " ") + (display (variable-name obj)) + (display ">")) + +(define-public (make-local-variable name location) + (make #:name name #:location location)) + +(define-public (make-top-level-variable name) + (make #:name name)) + +(define-public (variable? obj) + (is-a? obj )) + +(define-public (local-variable? obj) + (is-a? obj )) + +(define-public (external-variable? obj) + (is-a? obj )) + +(define-public (top-level-variable? obj) + (is-a? obj )) + +(define-public (variable-bound? var) + (assert variable? var) + (slot-bound? var 'value)) + +(define-public (variable-externalize! var) + (assert variable? var) + (if (local-variable? var) + (change-class var ))) + + +;;; +;;; VM environment +;;; + +(define-class () + (space #:accessor env-name-space #:init-value '()) + (args #:accessor env-arguments #:init-keyword #:args) + (vars #:accessor env-variables #:init-value '()) + (locs #:accessor env-locations #:init-value '()) + (exts #:accessor env-externals #:init-value #f) + (link #:accessor env-external-link #:init-keyword #:link)) + +(define-public (make-env syms link) + (let* ((syms (reverse syms)) + (args (map (lambda (sym) + (make-local-variable sym (make-location))) + syms)) + (env (make #:args args #:link link))) + (for-each (lambda (sym var) + (set! (env-name-space env) + (acons sym var (env-name-space env)))) + syms args) + env)) + +(define-public (make-top-level-env) + (make-env '() #f)) + +(define-public (env? obj) (is-a? obj )) + +(define-public (top-level-env? obj) + (and (env? obj) (not (env-external-link obj)))) + +(define-public (env-finalized? env) + (if (env-externals env) #t #f)) + +(define-public (env-add-variable! env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not add a variable after finalization")) + (let ((var (if (top-level-env? env) + (make-top-level-variable sym) + (let* ((locs (env-locations env)) + (loc (if (null? locs) + (make-location) + (begin + (set! (env-locations env) (cdr locs)) + (car locs))))) + (make-local-variable sym loc))))) + (set! (env-name-space env) (acons sym var (env-name-space env))) + (set! (env-variables env) (cons var (env-variables env))) + var)) + +(define-public (env-remove-variable! env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not remove a variable after finalization")) + (let ((var (assq-ref (env-name-space env) sym))) + (if (not var) + (error "No such variable: ~A\n" sym)) + (if (local-variable? var) + (set! (env-locations env) + (cons (variable-location var) (env-locations env)))) + (set! (env-name-space env) + (delq! (assq sym (env-name-space env)) (env-name-space env))) + var)) + +;; Find a varialbe in the environment + +(define-public (env-ref env sym) + (assert env? env) + (assert symbol? sym) + (if (env-finalized? env) + (error "You may not find a variable after finalization")) + (or (env-local-ref env sym) + (env-external-ref env sym) + (env-top-level-ref env sym) + (error "No way!"))) + +(define (env-local-ref env sym) + (if (assq sym (env-name-space env)) + (let ((var (assq-ref (env-name-space env) sym))) + (set! (variable-count var) (1+ (variable-count var))) + var) + #f)) + +(define (env-external-ref env sym) + (let ((ext-env (env-external-link env))) + (if (not ext-env) + #f + (let ((var (env-local-ref ext-env sym))) + (if var + (begin + (variable-externalize! var) + var) + (env-external-ref ext-env sym)))))) + +(define (env-top-level-ref env sym) + (let ((var (make-top-level-variable sym))) + (if (defined? sym) + ;; Get the value in the top-level + (let ((obj (eval sym (interaction-environment)))) + (set! (variable-value var) obj) + (set! (variable-type var) + (cond ((macro? obj) 'macro) + ((program? obj) 'program) + ((procedure? obj) 'function) + (else #f))))) + var)) + +;; Finalization + +(define-public (env-finalize! env) + (if (not (env-finalized? env)) + (let ((locs (uniq! (map variable-location + (append (filter local-variable? + (env-variables env)) + (env-arguments env))))) + (exts (filter external-variable? + (append (env-variables env) (env-arguments env))))) + (set! (env-locations env) locs) + (set! (env-externals env) (reverse! exts))))) + +(define-public (env-header env) + (env-finalize! env) + (let ((nvars (length (uniq! (map variable-location + (filter local-variable? + (env-variables env)))))) + (nexts (length (env-externals env))) + (exts (list->vector + (map (lambda (var) + (env-local-variable-address env var)) + (filter external-variable? + (reverse (env-arguments env))))))) + (list nvars nexts exts))) + +(define (get-offset obj list) + (- (length list) (length (memq obj list)))) + +(define-generic env-variable-address) + +(define-method (env-variable-address (env ) (var )) + (env-finalize! env) + (get-offset (variable-location var) (env-locations env))) + +(define-method (env-variable-address (env ) (var )) + (env-finalize! env) + (let loop ((depth 0) (env env)) + (let ((list (env-externals env))) + (cond ((null? list) + (loop depth (env-external-link env))) + ((memq var list) + (cons depth (get-offset var list))) + (else (loop (1+ depth) (env-external-link env))))))) + + +;;; +;;; Intermediate codes +;;; + +(define-public (make-code:unspecified env) + (assert env? env) + (make-code #:unspecified env)) + +(define-public (make-code:constant env obj) + (assert env? env) + (make-code #:constant env obj)) + +(define-public (make-code:ref env var) + (assert env? env) + (assert variable? var) + (let ((code (make-code #:ref env var))) + (set! (code-type code) (variable-type var)) + code)) + +(define-public (make-code:set env var val) + (assert env? env) + (assert variable? var) + (assert code? val) + (let ((code (make-code #:set env var val))) + (set! (variable-type var) (code-type val)) + (set! (code-type code) (variable-type var)) + code)) + +(define-public (make-code:program env nreqs restp body) + (assert env? env) + (assert integer? nreqs) + (assert boolean? restp) + (assert code? body) + (let ((code (make-code #:make-program env nreqs restp body))) + (set! (code-type code) 'program) + code)) + +(define-public (make-code:call env proc . args) + (assert env? env) + (assert (lambda (x) (or (variable? x) (code? x))) proc) + (assert-for-each code? args) + (apply make-code #:call env proc args)) + +(define-public (make-code:if env test consequent alternate) + (assert env? env) + (assert code? test) + (assert code? consequent) + (assert code? alternate) + (let ((code (make-code #:if env test consequent alternate))) + (if (eq? (code-type consequent) (code-type alternate)) + (set! (code-type code) (code-type consequent))) + code)) + +(define-public (make-code:and env . args) + (assert env? env) + (assert-for-each code? args) + (apply make-code #:and args)) + +(define-public (make-code:or env . args) + (assert env? env) + (assert-for-each code? args) + (apply make-code #:or args)) + +(define-public (make-code:begin env . body) + (assert env? env) + (assert-for-each code? body) + (let ((code (apply make-code #:begin env body))) + (set! (code-type code) (code-type (last body))) + code)) + +(define-public (make-code:until env test . body) + (assert env? env) + (assert code? test) + (assert-for-each code? body) + (apply make-code #:until env test body)) + +;;; types.scm ends here diff --git a/vm/utils.scm b/vm/utils.scm new file mode 100644 index 000000000..4a43375a3 --- /dev/null +++ b/vm/utils.scm @@ -0,0 +1,106 @@ +;;; utils.scm --- + +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; This file is part of Guile VM. + +;; Guile VM 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. +;; +;; Guile VM 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 Guile VM; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (vm utils) + :use-module (ice-9 and-let*) + :use-module (ice-9 format)) + +(export and-let*) + +(define-public (assert predicate obj) + (if (not (predicate obj)) + (scm-error 'wrong-type-arg #f + "Wrong type argument: ~S, ~S" + (list (procedure-name predicate) obj) #f))) + +(define-public (assert-for-each predicate list) + (for-each (lambda (x) (assert predicate x)) list)) + +(define-public (check-nargs args pred n) + (if (not (pred (length args) n)) + (error "Too many or few arguments"))) + +(define-public (last list) + (car (last-pair list))) + +(define-public (rassq key alist) + (let loop ((alist alist)) + (cond ((null? alist) #f) + ((eq? key (cdar alist)) (car alist)) + (else (loop (cdr alist)))))) + +(define-public (rassq-ref alist key) + (let ((obj (rassq key alist))) + (if obj (car obj) #f))) + +(define-public (map-if pred func list) + (let loop ((list list) (result '())) + (if (null? list) + (reverse! result) + (if (pred (car list)) + (loop (cdr list) (cons (func (car list)) result)) + (loop (cdr list) result))))) + +(define-public (map-tree func tree) + (cond ((null? tree) '()) + ((pair? tree) + (cons (map-tree func (car tree)) (map-tree func (cdr tree)))) + (else (func tree)))) + +(define-public (filter pred list) + (let loop ((list list) (result '())) + (if (null? list) + (reverse! result) + (if (pred (car list)) + (loop (cdr list) (cons (car list) result)) + (loop (cdr list) result))))) + +(define-public (uniq! list) + (do ((rest list (begin (set-cdr! rest (delq! (car rest) (cdr rest))) + (cdr rest)))) + ((null? rest) list))) + +(define-public (finalize obj) + (if (promise? obj) (force obj) obj)) + +(export time) +(define-macro (time form) + `(let* ((gc-start (gc-run-time)) + (tms-start (times)) + (result ,form) + (tms-end (times)) + (gc-end (gc-run-time)) + (get (lambda (proc start end) + (/ (- (proc end) (proc start)) + internal-time-units-per-second)))) + (display "clock utime stime cutime cstime gc\n") + (format #t "~5a ~5a ~5a ~6a ~6a ~a~%" + (get tms:clock tms-start tms-end) + (get tms:utime tms-start tms-end) + (get tms:stime tms-start tms-end) + (get tms:cutime tms-start tms-end) + (get tms:cstime tms-start tms-end) + (get id gc-start gc-end)) + result)) + +;;; utils.scm ends here -- 2.20.1