mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Initial revision
This commit is contained in:
Keisuke Nishida
commit
a98cef7e6c
36 changed files with 5255 additions and 0 deletions
1
AUTHORS
Normal file
1
AUTHORS
Normal file
|
|
@ -0,0 +1 @@
|
|||
Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
12
ChangeLog
Normal file
12
ChangeLog
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
2000-08-20 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
|
||||
* Version 0.2 is released.
|
||||
|
||||
2000-08-12 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
|
||||
* Version 0.1 is released.
|
||||
|
||||
2000-07-29 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
|
||||
* Version 0.0 is released.
|
||||
|
||||
7
Makefile.am
Normal file
7
Makefile.am
Normal file
|
|
@ -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
|
||||
0
NEWS
Normal file
0
NEWS
Normal file
0
README
Normal file
0
README
Normal file
1
THANKS
Normal file
1
THANKS
Normal file
|
|
@ -0,0 +1 @@
|
|||
Guile VM is motivated by QScheme.
|
||||
4
acconfig.h
Normal file
4
acconfig.h
Normal file
|
|
@ -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
|
||||
20
acinclude.m4
Normal file
20
acinclude.m4
Normal file
|
|
@ -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
|
||||
])
|
||||
6
autogen.sh
Executable file
6
autogen.sh
Executable file
|
|
@ -0,0 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
aclocal
|
||||
autoheader
|
||||
automake -a
|
||||
autoconf
|
||||
15
configure.in
Normal file
15
configure.in
Normal file
|
|
@ -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)
|
||||
2
doc/Makefile.am
Normal file
2
doc/Makefile.am
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
EXTRA_DIST = vm-spec.txt
|
||||
MAINTAINERCLEANFILES = Makefile.in
|
||||
78
doc/goops.mail
Normal file
78
doc/goops.mail
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
From: Mikael Djurfeldt <mdj@mdj.nada.kth.se>
|
||||
Subject: Re: After GOOPS integration: Computation with native types!
|
||||
To: Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com
|
||||
Cc: djurfeldt@nada.kth.se
|
||||
Date: 17 Aug 2000 03:01:13 +0200
|
||||
|
||||
Keisuke Nishida <kxn30@po.cwru.edu> 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. ;-)]
|
||||
|
||||
402
doc/vm-spec.txt
Normal file
402
doc/vm-spec.txt
Normal file
|
|
@ -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 . #<undefined>) ; ac = #<undefined>
|
||||
%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 #<bytecode xxx> ; create a program in this environment
|
||||
%unbind ; remove local bindings
|
||||
%savet (foo . #<undefined>) ; save the program in foo
|
||||
|
||||
(foo) ->
|
||||
|
||||
%loadt (foo . #<program xxx>) ; 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 . #<program xxx>) ; 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 . #<primitive-procedure version>) ; no argument
|
||||
|
||||
(display "hello") ->
|
||||
|
||||
%loadi "hello"
|
||||
%func1 (display . #<primitive-procedure display>) ; one argument
|
||||
|
||||
(open-file "file" "w") ->
|
||||
|
||||
%pushi "file"
|
||||
%loadi "w"
|
||||
%func2 (open-file . #<primitive-procedure open-file>) ; two arguments
|
||||
|
||||
(equal 1 2 3)
|
||||
|
||||
%pushi 1
|
||||
%pushi 2
|
||||
%pushi 3
|
||||
%loadi 3 ; the number of arguments
|
||||
%func (equal . #<primitive-procedure equal>) ; many arguments
|
||||
|
||||
** Subprogram call
|
||||
|
||||
(define (plus a b) (+ a b))
|
||||
(plus 1 2) ->
|
||||
|
||||
%pushi 1 ; argument 1
|
||||
%pushi 2 ; argument 2
|
||||
%loadt (plus . #<program xxx>) ; 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
|
||||
47
src/Makefile.am
Normal file
47
src/Makefile.am
Normal file
|
|
@ -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
|
||||
6
src/guile-compile.in
Normal file
6
src/guile-compile.in
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#!@bindir@/@PACKAGE@ -s
|
||||
!#
|
||||
|
||||
(use-modules (vm compile))
|
||||
|
||||
(for-each compile-file (cdr (command-line)))
|
||||
58
src/guile-vm.c
Normal file
58
src/guile-vm.c
Normal file
|
|
@ -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 <libguile.h>
|
||||
|
||||
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 */
|
||||
}
|
||||
60
src/test.scm
Normal file
60
src/test.scm
Normal file
|
|
@ -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"))
|
||||
88
src/vm-snarf.h
Normal file
88
src/vm-snarf.h
Normal file
|
|
@ -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 */
|
||||
226
src/vm.h
Normal file
226
src/vm.h
Normal file
|
|
@ -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 <libguile.h>
|
||||
|
||||
|
||||
/*
|
||||
* 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 */
|
||||
132
src/vm_engine.c
Normal file
132
src/vm_engine.c
Normal file
|
|
@ -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
|
||||
345
src/vm_engine.h
Normal file
345
src/vm_engine.h
Normal file
|
|
@ -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; }
|
||||
188
src/vm_number.c
Normal file
188
src/vm_number.c
Normal file
|
|
@ -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);
|
||||
}
|
||||
111
src/vm_scheme.c
Normal file
111
src/vm_scheme.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
549
src/vm_system.c
Normal file
549
src/vm_system.c
Normal file
|
|
@ -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;
|
||||
}
|
||||
16
test/Makefile.am
Normal file
16
test/Makefile.am
Normal file
|
|
@ -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 $<
|
||||
20
test/control.scm
Normal file
20
test/control.scm
Normal file
|
|
@ -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)
|
||||
60
test/procedure.scm
Normal file
60
test/procedure.scm
Normal file
|
|
@ -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)
|
||||
50
test/queens.scm
Normal file
50
test/queens.scm
Normal file
|
|
@ -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)))
|
||||
12
test/test.scm
Normal file
12
test/test.scm
Normal file
|
|
@ -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))
|
||||
14
vm/Makefile.am
Normal file
14
vm/Makefile.am
Normal file
|
|
@ -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
|
||||
500
vm/bytecomp.scm
Normal file
500
vm/bytecomp.scm
Normal file
|
|
@ -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 #<vm:local-var>
|
||||
;; %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 #<vm:external-var>
|
||||
;; %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 #<vm:top-level-var>
|
||||
;; %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 #<vm:local-var> 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 #<vm:external-var> 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 #<vm:top-level-var> 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
|
||||
310
vm/compile.scm
Normal file
310
vm/compile.scm
Normal file
|
|
@ -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
|
||||
221
vm/shell.scm
Normal file
221
vm/shell.scm
Normal file
|
|
@ -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
|
||||
367
vm/types.scm
Normal file
367
vm/types.scm
Normal file
|
|
@ -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 <vm:code> ()
|
||||
(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 <vm:code>) port)
|
||||
(display "#<vm:")
|
||||
(display (keyword->symbol (code-tag obj)))
|
||||
(map (lambda (obj) (display " ") (write obj port))
|
||||
(code-args obj))
|
||||
(display ">"))
|
||||
|
||||
(define-public (code? obj)
|
||||
(is-a? obj <vm:code>))
|
||||
|
||||
(define-public (make-code tag env . args)
|
||||
(make <vm:code> #:tag tag #:env env #:args args))
|
||||
|
||||
|
||||
;;;
|
||||
;;; VM label
|
||||
;;;
|
||||
|
||||
(define-class <vm:label> ()
|
||||
(pos #:accessor label-position))
|
||||
|
||||
(export label-position)
|
||||
|
||||
(define-public (label? obj)
|
||||
(is-a? obj <vm:label>))
|
||||
|
||||
(define-public (make-label)
|
||||
(make <vm:label>))
|
||||
|
||||
|
||||
;;;
|
||||
;;; VM location
|
||||
;;;
|
||||
|
||||
(define-class <vm:location> ())
|
||||
|
||||
(define (make-location)
|
||||
(make <vm:location>))
|
||||
|
||||
|
||||
;;;
|
||||
;;; VM variable
|
||||
;;;
|
||||
|
||||
(define-class <vm:var> ()
|
||||
(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 <vm:local-var> (<vm:var>))
|
||||
(define-class <vm:external-var> (<vm:var>))
|
||||
(define-class <vm:top-level-var> (<vm:var>))
|
||||
|
||||
(export variable-name variable-type variable-value variable-count)
|
||||
|
||||
(define-method (write (obj <vm:var>) port)
|
||||
(display "#")
|
||||
(display (class-name (class-of obj)))
|
||||
(display " ")
|
||||
(display (variable-name obj))
|
||||
(display ">"))
|
||||
|
||||
(define-public (make-local-variable name location)
|
||||
(make <vm:local-var> #:name name #:location location))
|
||||
|
||||
(define-public (make-top-level-variable name)
|
||||
(make <vm:top-level-var> #:name name))
|
||||
|
||||
(define-public (variable? obj)
|
||||
(is-a? obj <vm:var>))
|
||||
|
||||
(define-public (local-variable? obj)
|
||||
(is-a? obj <vm:local-var>))
|
||||
|
||||
(define-public (external-variable? obj)
|
||||
(is-a? obj <vm:external-var>))
|
||||
|
||||
(define-public (top-level-variable? obj)
|
||||
(is-a? obj <vm:top-level-var>))
|
||||
|
||||
(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:external-var>)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; VM environment
|
||||
;;;
|
||||
|
||||
(define-class <vm:env> ()
|
||||
(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 <vm:env> #: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 <vm:env>))
|
||||
|
||||
(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 <vm:env>) (var <vm:local-var>))
|
||||
(env-finalize! env)
|
||||
(get-offset (variable-location var) (env-locations env)))
|
||||
|
||||
(define-method (env-variable-address (env <vm:env>) (var <vm:external-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
|
||||
106
vm/utils.scm
Normal file
106
vm/utils.scm
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue