From: Keisuke Nishida Date: Tue, 22 Aug 2000 15:54:19 +0000 (+0000) Subject: Initial revision X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/a98cef7e6c42d40c8d77640030d3eb2697ae647b Initial revision --- a98cef7e6c42d40c8d77640030d3eb2697ae647b 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