summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-01 05:03:41 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-01 05:03:41 +0000
commit17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d (patch)
treedb77f6e4b51ff1a58e1016e977a3591eb856ef78
parentc092937bd5da5b3ca35fd7a7cc54538767fe6ab5 (diff)
downloadguile-17e90c5e25a7a2e453742044ee6a3fa5f27e9e5d.tar.gz
New VM.
-rw-r--r--.cvsignore2
-rw-r--r--ChangeLog108
-rw-r--r--Makefile.am2
-rw-r--r--THANKS2
-rw-r--r--configure.in4
-rw-r--r--module/.cvsignore2
-rw-r--r--module/Makefile.am13
-rw-r--r--module/language/ghil/GPKG.def8
-rw-r--r--module/language/ghil/spec.scm31
-rw-r--r--module/system/base/language.scm111
-rw-r--r--module/system/base/module.scm222
-rw-r--r--module/system/base/syntax.scm98
-rw-r--r--module/system/il/compile.scm196
-rw-r--r--module/system/il/ghil.scm266
-rw-r--r--module/system/il/glil.scm184
-rw-r--r--module/system/il/macros.scm435
-rw-r--r--module/system/repl/command.scm506
-rw-r--r--module/system/repl/common.scm93
-rw-r--r--module/system/repl/describe.scm364
-rw-r--r--module/system/repl/repl.scm74
-rw-r--r--module/system/vm/assemble.scm327
-rw-r--r--module/system/vm/conv.scm137
-rw-r--r--module/system/vm/core.scm35
-rw-r--r--module/system/vm/disasm.scm118
-rw-r--r--module/system/vm/frame.scm32
-rw-r--r--module/system/vm/profile.scm66
-rw-r--r--module/system/vm/trace.scm75
-rw-r--r--src/.cvsignore6
-rw-r--r--src/Makefile.am36
-rw-r--r--src/envs.c250
-rw-r--r--src/envs.h73
-rw-r--r--src/guile-compile.in6
-rw-r--r--src/guile-vm.c12
-rw-r--r--src/instructions.c138
-rw-r--r--src/instructions.h84
-rw-r--r--src/programs.c209
-rw-r--r--src/programs.h94
-rw-r--r--src/test.scm60
-rw-r--r--src/vm.c1260
-rw-r--r--src/vm.h242
-rw-r--r--src/vm_engine.c122
-rw-r--r--src/vm_engine.h458
-rw-r--r--src/vm_expand.h42
-rw-r--r--src/vm_loader.c133
-rw-r--r--src/vm_number.c200
-rw-r--r--src/vm_scheme.c113
-rw-r--r--src/vm_system.c579
47 files changed, 5534 insertions, 2094 deletions
diff --git a/.cvsignore b/.cvsignore
index 5b27a2a54..92045d53c 100644
--- a/.cvsignore
+++ b/.cvsignore
@@ -1,4 +1,4 @@
-.cvsignore
+misc
libtool
config.log
config.cache
diff --git a/ChangeLog b/ChangeLog
index 42f3c41d7..56b451d7b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,111 +1,3 @@
-2000-10-05 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * vm/compile.scm (canon-formals): Use `values'.
- (parse-lambda): Use `call-with-values'.
-
-2000-09-29 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/Makefile.am: Don't use guile-snarf to generate instruction
- table. Create *.i by using grep.
- * src/vm_expand.h: Replaced from vm-snarf.h.
- * src/vm.c, src/vm.h, src/vm_engine.c: Include *.i.
- * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Don't include
- "vm-snarf.h".
-
-2000-09-27 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h,
- src/vm-snarf.h: Indirect threaded.
- * src/Makefile.am, src/.cvsignore: Updated.
-
-2000-09-22 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm.c: SCM_CHARS -> SCM_SYMBOL_CHARS.
-
-2000-09-22 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm_system.c (call): Call return-hook before reinstating a
- continuation.
- (tail_call): Call return-hook before a proper tail call.
-
-2000-09-20 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm.c (scm_name_property): New variable.
- (scm_name, scm_set_name_x): New procedures.
- (scm_smob_print_with_name, init_name_property): New functions.
- (print_program, scm_program_name): Removed.
- (init_program_type, init_vm_type): Use scm_smob_print_with_name.
- (scm_init_vm): Call init_name_property.
- * src/vm_system.c (name): New instruction.
- (savet): Don't set name.
- * vm/shell.scm (vm-frame->call): Updated.
- * vm/bytecomp.scm (translate-ref): Combined translate-local-ref,
- translate-external-ref, and translate-top-level-ref.
- (translate-set): Combined translate-local-set,
- translate-external-set, and translate-top-level-ref.
- Set a name to the object.
-
- * src/vm_number.c (FUNC2): New macro.
- (add2, sub2): Use FUNC2.
- (remainder): New instruction.
-
- * vm/bytecomp.scm (translate-and, translate-or): Bug fixed.
-
-2000-09-20 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm_scheme.c (cons): Bug fixed.
- * src/vm_system.c (br_if_null): Set ac = SCM_BOOL_T if null.
- (br_if_not_null): Set ac = SCM_BOOL_F if not null.
-
-2000-09-11 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * autogen.sh: Run aclocal with check where guile.m4 is installed.
-
-2000-09-10 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm_system.c (push_list): New instruction.
- * src/vm_engine.c (VM_NAME): Don't validate VM and PROGRAM.
- * src/vm.c (scm_vm_apply): New procedure.
- (apply_program): New function.
- (init_program_type): Set the apply function for the program type.
-
- * src/vm.c (lookup_variable): Use scm_eval_closure_lookup.
-
-2000-09-03 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm_system.c (tail_call): Use SCM_TICK at the beginning.
-
-2000-09-02 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm_engine.c (VM_NAME): Renamed the variable `an' to `nargs'.
- Removed the variables `a2' and `a3'.
- * src/vm_engine.h (VM_SETUP_ARGS2, VM_SETUP_ARGS3): Setup local
- variables.
- (VM_SETUP_ARGS4): Removed.
- * src/vm_system.c, src/vm_scheme.c, src/vm_number.c: Updated.
-
-2000-08-24 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm.c (lookup_variable): New function.
- (scm_make_bytecode): Call lookup_variable for top-level variables.
- * src/vm_engine.h (VM_VARIABLE_REF, VM_VARIABLE_SET): New macros.
- * src/vm_system.c (TOPLEVEL_VAR, TOPLEVEL_VAR_SET): Removed.
- Use VM_VARIABLE_REF and VM_VARIABLE_SET instead.
-
-2000-08-22 Keisuke Nishida <kxn30@po.cwru.edu>
-
- * src/vm.c, src/vm.h, src/vm_engine.c, src/vm_engine.h,
- src/vm_system.c: Create external frames dynamically.
- * vm/shell.scm: Use frame-external-link.
-
- * vm/compile.scm (compile-file): Output "(use-modules (vm vm))".
-
- * vm/types.scm (make-code): Check argument types.
- (make-code:and, make-code:or): Pass env to make-code.
-
- * vm/bytecomp.scm (translate-and, translate-or): Don't branch on
- the last expression.
-
2000-08-20 Keisuke Nishida <kxn30@po.cwru.edu>
* Version 0.2 is released.
diff --git a/Makefile.am b/Makefile.am
index e38d314b0..1b0e4dd45 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,4 +1,4 @@
-SUBDIRS = src vm doc test
+SUBDIRS = src doc module
EXTRA_DIST = acconfig.h
diff --git a/THANKS b/THANKS
index da16a3a50..507d4ec00 100644
--- a/THANKS
+++ b/THANKS
@@ -1 +1 @@
-Guile VM is motivated by QScheme.
+Guile VM was motivated by QScheme and librep.
diff --git a/configure.in b/configure.in
index d0f58bb29..eda04c472 100644
--- a/configure.in
+++ b/configure.in
@@ -1,5 +1,5 @@
AC_INIT(src/guile-vm.c)
-AM_INIT_AUTOMAKE(guile-vm, 0.2)
+AM_INIT_AUTOMAKE(guile-vm, 0.3)
AM_CONFIG_HEADER(src/config.h)
GUILE_FLAGS
@@ -12,4 +12,4 @@ AC_PROG_LN_S
AM_PROG_LIBTOOL
AC_C_LABELS_AS_VALUES
-AC_OUTPUT(Makefile src/Makefile vm/Makefile doc/Makefile test/Makefile)
+AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile)
diff --git a/module/.cvsignore b/module/.cvsignore
new file mode 100644
index 000000000..282522db0
--- /dev/null
+++ b/module/.cvsignore
@@ -0,0 +1,2 @@
+Makefile
+Makefile.in
diff --git a/module/Makefile.am b/module/Makefile.am
new file mode 100644
index 000000000..aa748128e
--- /dev/null
+++ b/module/Makefile.am
@@ -0,0 +1,13 @@
+guiledatadir = $(datadir)/guile
+
+install-data-local:
+ $(mkinstalldirs) $(DESTDIR)$(guiledatadir)
+ cp -rp module/* $(DESTDIR)$(guiledatadir)
+ rm -f $(guiledatadir)/system/vm/libcore.so \
+ && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so
+
+install-data-local:
+ $(mkinstalldirs) $(DESTDIR)$(guiledatadir)
+ cp -rp module/* $(DESTDIR)$(guiledatadir)
+ rm -f $(guiledatadir)/system/vm/libcore.so \
+ && $(LN_S) $(libdir)/libguilevm.so $(guiledatadir)/system/vm/libcore.so
diff --git a/module/language/ghil/GPKG.def b/module/language/ghil/GPKG.def
new file mode 100644
index 000000000..999d2ef88
--- /dev/null
+++ b/module/language/ghil/GPKG.def
@@ -0,0 +1,8 @@
+;;; GHIL package definition -*- gscheme -*-
+
+(define-package ghil
+ :category Language
+ :version "0.3"
+ :author "Keisuke Nishida <kxn30@po.cwru.edu>"
+ :modules ((spec "spec.scm" gscheme))
+ )
diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm
new file mode 100644
index 000000000..cfd6222e1
--- /dev/null
+++ b/module/language/ghil/spec.scm
@@ -0,0 +1,31 @@
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; 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.
+
+(define-module (language ghil spec)
+ :use-module (system base language)
+ :use-module (system base module)
+ :export (ghil))
+
+(define-language ghil
+ :title "Guile High Intermediate Language (GHIL)"
+ :version "0.3"
+ :reader read
+ :printer write
+ :environment (make-vmodule)
+ )
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
new file mode 100644
index 000000000..c979d5cef
--- /dev/null
+++ b/module/system/base/language.scm
@@ -0,0 +1,111 @@
+;;; Multi-language support
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base language)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system il compile)
+ :use-module (system vm assemble)
+ :use-module (ice-9 regex)
+ :export (define-language lookup-language
+ read-in compile-in print-in compile-file-in load-file-in))
+
+
+;;;
+;;; Language class
+;;;
+
+(define-vm-class <language> ()
+ name title version environment
+ (reader)
+ (expander (lambda (x) x))
+ (translator (lambda (x) x))
+ (evaler #f)
+ (printer)
+ )
+
+(define-method (write (lang <language>) port)
+ (display "#<language " port)
+ (display lang.name port)
+ (display ">"))
+
+(define-macro (define-language name . spec)
+ `(define ,name (,make ,<language> :name ',name ,@spec)))
+
+(define (lookup-language name)
+ (let ((m (resolve-module `(language ,name spec))))
+ (if (module-bound? m name)
+ (module-ref m name)
+ (error "No such language:" name))))
+
+
+;;;
+;;; Evaluation interface
+;;;
+
+(define (read-in lang . port)
+ (lang.reader (if (null? port) (current-input-port) (car port))))
+
+(define (compile-in form env lang . opts)
+ (catch 'result
+ (lambda ()
+ ;; expand
+ (set! form (lang.expander form))
+ (if (memq :e opts) (throw 'result form))
+ ;; translate
+ (set! form (lang.translator form))
+ (if (memq :t opts) (throw 'result form))
+ ;; compile
+ (set! form (apply compile form env opts))
+ (if (memq :c opts) (throw 'result form))
+ ;; assemble
+ (apply assemble form env opts))
+ (lambda (key val) val)))
+
+(define (print-in val lang . port)
+ (lang.printer val (if (null? port) (current-output-port) (car port))))
+
+(define (compile-file-in file env lang . opts)
+ (let* ((code (call-with-input-file file
+ (lambda (in)
+ (do ((x (read-in lang in) (read-in lang in))
+ (l '() (cons (lang.translator (lang.expander x)) l)))
+ ((eof-object? x) (reverse! l))))))
+ (asm (apply compile (cons '@begin code) env opts))
+ (bytes (apply assemble asm env opts)))
+ (call-with-output-file (object-file-name file)
+ (lambda (out) (uniform-vector-write bytes out)))))
+
+(define (load-file-in file env lang)
+ (let ((compiled (object-file-name file)))
+ (if (or (not (file-exists? compiled))
+ (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
+ (compile-file-in file env lang))
+ (call-with-input-file compiled
+ (lambda (p)
+ (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
+ (uniform-vector-read! bytes p)
+ bytes)))))
+
+(define (object-file-name file)
+ (let ((m (string-match "\\.[^.]*$" file)))
+ (string-append (if m (match:prefix m) file) ".go")))
diff --git a/module/system/base/module.scm b/module/system/base/module.scm
new file mode 100644
index 000000000..99cc0ec7b
--- /dev/null
+++ b/module/system/base/module.scm
@@ -0,0 +1,222 @@
+;;; Module system
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base module)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base language)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 common-list))
+
+(define (expand-file-name file dir)
+ (string-append dir "/" file))
+
+
+;;;
+;;; Environment
+;;;
+
+(dynamic-call "scm_init_envs" (dynamic-link "libguilevm.so"))
+
+(export env-identifier)
+(define-generic env-identifier)
+(define-generic env-bound?)
+(define-generic env-ref)
+(define-generic env-set!)
+(define-generic env-define)
+
+(export global-ref)
+
+(define (global-ref identifier)
+ (let loop ((e *root-package*) (l (identifier->list identifier)))
+ (cond ((null? l) e)
+ (else (loop (env-ref e (car l)) (cdr l))))))
+
+(define (load-env identifier)
+ (let ((x (global-ref identifier))) x.env))
+
+(define (identifier->list identifier)
+ (let loop ((s (symbol->string identifier)) (l '()))
+ (let ((m (string-match "::" s)))
+ (if m
+ (loop (match:suffix m) (cons (string->symbol (match:prefix m)) l))
+ (reverse! (cons (string->symbol s) l))))))
+
+(define-public (identifier-split identifier)
+ (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+ (if m
+ (values (string->symbol (match:prefix m))
+ (string->symbol (match:substring m 1)))
+ (values #f identifier))))
+
+
+;;;
+;;; Modules
+;;;
+
+(define-vm-class <vmodule> (<env>)
+ (env (make-env))
+ (bootcode))
+
+(export make-vmodule)
+
+(define (make-vmodule)
+ (make <vmodule>))
+
+(define-method (env-identifier (m <vmodule>))
+ (env-identifier m.env))
+
+(define-method (env-define (m <vmodule>) (s <symbol>) v)
+ (env-define m.env s v))
+
+
+;;;
+;;; Packages
+;;;
+
+(define *package-def* "GPKG.def")
+
+(define-vm-class <package> (<env>)
+ (env (make-env)))
+
+(define-method (env-bound? (p <package>) (s <symbol>))
+ (if (not (env-bound? p.env s))
+ (cond ((package-lookup p s) => (lambda (v) (env-define p.env s v) #t))
+ (else #f))))
+
+(define-method (env-ref (p <package>) (s <symbol>))
+ (env-bound? p s)
+ (env-ref p.env s))
+
+(define-method (env-define (p <package>) (s <symbol>) (c <env>))
+ (env-define p.env s c)
+ (let ((id (cond ((env-identifier p.env) =>
+ (lambda (id)
+ (string->symbol (format #f "~A::~A" id s))))
+ (else s))))
+ (set-env-identifier! c.env id)))
+
+(define (try-load-package dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (if (file-exists? (expand-file-name *package-def* dir))
+ (make-custom-package dir)
+ (make-plain-package dir))
+ #f))
+
+;; plain package
+
+(define-vm-class <plain-package> (<package>)
+ directory)
+
+(define (make-plain-package dir)
+ (make <plain-package> :directory dir))
+
+(define-method (package-lookup (p <plain-package>) (s <symbol>))
+ (let ((file (expand-file-name (string-downcase! (symbol->string s))
+ p.directory)))
+ (or (try-load-package file)
+ (try-load-vmodule file))))
+
+(define (try-load-vmodule file)
+ (or (try-load-compiled-vmodule file)
+ (try-load-source-vmodule file)))
+
+(define (try-load-compiled-vmodule file) #f)
+
+(define (try-load-source-vmodule file) #f)
+
+;; custom package
+
+(define-vm-class <custom-package> (<package>)
+ directory name category version author modules)
+
+(define (make-custom-package dir)
+ (call-with-input-file (expand-file-name *package-def* dir)
+ (lambda (p)
+ (apply make <custom-package> :directory dir :name (cdr (read p))))))
+
+(define-method (package-lookup (p <custom-package>) (s <symbol>))
+ (and-let* ((entry (assq-ref p.modules s)))
+ (let ((module (make-vmodule)))
+ (env-define p s module)
+ (let* ((file (expand-file-name (car entry) p.directory))
+ (code (load-file-in file module (lookup-language (cadr entry)))))
+ (set! module.bootcode code))
+ module)))
+
+;; multi package
+
+(define-vm-class <multi-package> (<package>)
+ packages)
+
+(define (make-multi-package dirs)
+ (let ((packages (pick id (map try-load-package dirs))))
+ (make <multi-package> :packages packages)))
+
+(define-method (package-lookup (p <multi-package>) (s <symbol>))
+ (list-fold (lambda (p d)
+ (let ((c (and (env-bound? p s) (env-ref p s))))
+ (if c (if d (error "Module name conflict" d c) c) d)))
+ #f p.packages))
+
+
+;;;
+;;; Guile old module
+;;;
+
+(define (import-old-module! m module)
+ (hash-fold (lambda (k v d) (env-define m k (variable-ref v)))
+ #f (module-obarray module)))
+
+
+;;;
+;;; Current modules
+;;;
+
+(export current-vmodule set-current-vmodule!
+ current-evaluator set-current-evaluator!)
+
+(define *current-module* #f)
+(define (current-vmodule) *current-module*)
+(define (set-current-vmodule! m) (set! *current-module* m))
+
+(define *current-evaluator* #f)
+(define (current-evaluator) *current-evaluator*)
+(define (set-current-evaluator! e) (set! *current-evaluator* e))
+
+
+;;;
+;;; Standard modules/packages
+;;;
+
+(define *root-package*
+ (make-multi-package '("/usr/local/share/guile/site")))
+
+(let ((user (make-vmodule)))
+ (env-define *root-package* 'user user))
+
+(let ((core (make-vmodule)))
+ (env-define *root-package* 'core core)
+ (hash-fold (lambda (s v d) (env-define core s v)) #f (builtin-bindings)))
+
+(let ((module (make-vmodule)))
+ (env-define (global-ref 'System::Base) 'module module)
+ (import-old-module! module (current-module)))
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
new file mode 100644
index 000000000..fab3f0bd0
--- /dev/null
+++ b/module/system/base/syntax.scm
@@ -0,0 +1,98 @@
+;;; Guile VM specific syntaxes and utilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base syntax)
+ :use-module (oop goops)
+ :use-module (ice-9 match)
+ :use-module (ice-9 receive)
+ :use-module (ice-9 and-let-star)
+ :export (match and-let* receive))
+
+
+;;;
+;;; Keywords by `:KEYWORD'
+;;;
+
+(read-set! keywords 'prefix)
+
+
+;;;
+;;; Dot expansion
+;;;
+
+;; FOO.BAR -> (slot FOO 'BAR)
+
+(define (expand-dot! x)
+ (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x))
+ ((pair? x)
+ (cond ((memq (car x) '(quote quasiquote)) x)
+ (else (set-car! x (expand-dot! (car x)))
+ (set-cdr! x (expand-dot! (cdr x)))
+ x)))
+ (else x)))
+
+(define (expand-symbol x)
+ (let loop ((s (symbol->string x)))
+ (let ((i (string-rindex s #\.)))
+ (if i
+ `(slot ,(loop (substring s 0 i))
+ (quote ,(string->symbol (substring s (1+ i)))))
+ (string->symbol s)))))
+
+(define syntax expand-dot!)
+(export-syntax syntax)
+
+;; slot accessor
+(define slot (make-procedure-with-setter slot-ref slot-set!))
+(export slot)
+
+
+;;;
+;;; Simplified define-class
+;;;
+
+;; (define-vm-class <foo> () (x 1) (y 2)) =>
+;;
+;; (define-class <foo> ()
+;; (a :init-keyword :a :init-form 1)
+;; (b :init-keyword :b :init-form 2))
+
+(define-macro (define-vm-class name supers . rest)
+ `(define-class ,name ,supers
+ ,@(map (lambda (def)
+ (if (not (pair? def)) (set! def (list def)))
+ (let ((name (car def)) (rest (cdr def)))
+ (cons* name :init-keyword (symbol->keyword name)
+ (if (or (null? rest) (keyword? (car rest)))
+ rest
+ (cons :init-form rest)))))
+ rest)))
+
+(export-syntax define-vm-class)
+
+;;;
+;;; Other utilities
+;;;
+
+(define-public (list-fold f d l)
+ (if (null? l)
+ d
+ (list-fold f (f (car l) d) (cdr l))))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
new file mode 100644
index 000000000..fa73486e6
--- /dev/null
+++ b/module/system/il/compile.scm
@@ -0,0 +1,196 @@
+;;; GHIL -> GLIL compiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il compile)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system il glil)
+ :use-module (system il ghil)
+ :use-module (ice-9 common-list)
+ :export (compile))
+
+(define (compile x e . opts)
+ (set! x (parse-ghil x e))
+ (if (memq :O opts) (set! x (optimize x)))
+ (codegen x))
+
+
+;;;
+;;; Stage 2: Optimization
+;;;
+
+(define (optimize x)
+ (match x
+ (($ <ghil-call> proc args)
+ (match proc
+ ;; ((@lambda (VAR...) BODY...) ARG...) =>
+ ;; (@let ((VAR ARG) ...) BODY...)
+ (($ <ghil-lambda> env vars #f body)
+ (optimize (make-<ghil-bind> vars args body)))
+ (else
+ (make-<ghil-call> (optimize proc) (for-each optimize args)))))
+ (else x)))
+
+
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(define *ia-void* (make-<glil-void>))
+(define *ia-drop* (make-<glil-inst> 'drop))
+(define *ia-return* (make-<glil-inst> 'return))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+ (case var.kind
+ ((argument)
+ (make-<glil-argument> op var.index))
+ ((local)
+ (make-<glil-local> op var.index))
+ ((external)
+ (do ((depth 0 (1+ depth))
+ (e env e.parent))
+ ((eq? e var.env)
+ (make-<glil-external> op depth var.index))))
+ ((module)
+ (make-<glil-module> op var.env var.name))
+ (else (error "Unknown kind of variable:" var))))
+
+(define (codegen ghil)
+ (let ((stack '()))
+ (define (push-code! code)
+ (set! stack (cons code stack)))
+ (define (comp tree tail drop)
+ ;; possible tail position
+ (define (comp-tail tree) (comp tree tail drop))
+ ;; push the result
+ (define (comp-push tree) (comp tree #f #f))
+ ;; drop the result
+ (define (comp-drop tree) (comp tree #f #t))
+ ;; return this code if necessary
+ (define (return-code! code)
+ (if (not drop) (push-code! code))
+ (if tail (push-code! *ia-return*)))
+ ;; return void if necessary
+ (define (return-void!) (return-code! *ia-void*))
+ ;;
+ ;; dispatch
+ (match tree
+ (($ <ghil-void>)
+ (return-void!))
+
+ (($ <ghil-quote> obj)
+ (return-code! (make-<glil-const> obj)))
+
+ (($ <ghil-ref> env var)
+ (return-code! (make-glil-var 'ref env var)))
+
+ (($ <ghil-set> env var val)
+ (comp-push val)
+ (push-code! (make-glil-var 'set env var))
+ (return-void!))
+
+ (($ <ghil-if> test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (jump L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (push-code! (make-<glil-branch> 'br-if-not L1))
+ (comp-tail then)
+ (if (not tail) (push-code! (make-<glil-jump> L2)))
+ (push-code! (make-<glil-label> L1))
+ (comp-tail else)
+ (if (not tail) (push-code! (make-<glil-label> L2)))))
+
+ (($ <ghil-begin> exps)
+ ;; EXPS...
+ ;; TAIL
+ (if (null? exps)
+ (return-void!)
+ (do ((exps exps (cdr exps)))
+ ((null? (cdr exps))
+ (comp-tail (car exps)))
+ (comp-drop (car exps)))))
+
+ (($ <ghil-bind> env vars vals body)
+ ;; VALS...
+ ;; (set VARS)...
+ ;; BODY
+ (for-each comp-push vals)
+ (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
+ (reverse vars))
+ (comp-tail body))
+
+ (($ <ghil-lambda> vars rest body)
+ (return-code! (codegen tree)))
+
+ (($ <ghil-call> proc args)
+ ;; ARGS...
+ ;; PROC
+ ;; ([tail-]call NARGS)
+ (for-each comp-push args)
+ (comp-push proc)
+ (let ((inst (if tail 'tail-call 'call)))
+ (push-code! (make-<glil-call> inst (length args))))
+ (if drop (push-code! *ia-drop*)))
+
+ (($ <ghil-inst> inst args)
+ ;; ARGS...
+ ;; (INST)
+ (for-each comp-push args)
+ (push-code! (make-<glil-inst> inst))
+ (if drop (push-code! *ia-drop*))
+ (if tail (push-code! *ia-return*)))))
+ ;;
+ ;; main
+ (match ghil
+ (($ <ghil-lambda> env args rest body)
+ (let* ((vars env.variables)
+ (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
+ (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))
+ ;; initialize variable indexes
+ (finalize-index! args)
+ (finalize-index! locs)
+ (finalize-index! exts)
+ ;; export arguments
+ (do ((n 0 (1+ n)) (l args (cdr l)))
+ ((null? l))
+ (let ((v (car l)))
+ (if (eq? v.kind 'external)
+ (begin (push-code! (make-<glil-argument> 'ref n))
+ (push-code! (make-<glil-external> 'set 0 v.index))))))
+ ;; compile body
+ (comp body #t #f)
+ ;; create GLIL
+ (make-<glil-asm> (length args) (if rest 1 0) (length locs)
+ (length exts) (reverse! stack)))))))
+
+(define (finalize-index! list)
+ (do ((n 0 (1+ n))
+ (l list (cdr l)))
+ ((null? l))
+ (let ((v (car l))) (set! v.index n))))
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
new file mode 100644
index 000000000..9fdcf97fa
--- /dev/null
+++ b/module/system/il/ghil.scm
@@ -0,0 +1,266 @@
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il ghil)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (ice-9 match)
+ :use-module (ice-9 regex)
+ :export
+ (parse-ghil
+ make-<ghil-void> <ghil-void>?
+ make-<ghil-quote> <ghil-quote>? <ghil-quote>-1
+ make-<ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2
+ make-<ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3
+ make-<ghil-if> <ghil-if>? <ghil-if>-1 <ghil-if>-2 <ghil-if>-3
+ make-<ghil-begin> <ghil-begin>? <ghil-begin>-1
+ make-<ghil-bind> <ghil-bind>?
+ <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4
+ make-<ghil-lambda> <ghil-lambda>?
+ <ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4
+ make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2
+ make-<ghil-inst> <ghil-inst>? <ghil-inst>-1 <ghil-inst>-2
+ ))
+
+
+;;;
+;;; Parse tree
+;;;
+
+(define-structure (<ghil-void>))
+(define-structure (<ghil-quote> obj))
+(define-structure (<ghil-ref> env var))
+(define-structure (<ghil-set> env var val))
+(define-structure (<ghil-if> test then else))
+(define-structure (<ghil-begin> exps))
+(define-structure (<ghil-bind> env vars vals body))
+(define-structure (<ghil-lambda> env args rest body))
+(define-structure (<ghil-call> proc args))
+(define-structure (<ghil-inst> inst args))
+
+
+;;;
+;;; Variables
+;;;
+
+(define-vm-class <ghil-var> ()
+ env name kind type value index)
+
+(define (make-ghil-var env name kind)
+ (make <ghil-var> :env env :name name :kind kind))
+
+
+;;;
+;;; Modules
+;;;
+
+(define-vm-class <ghil-mod> ()
+ (module)
+ (table '())
+ (imports '()))
+
+(define (make-ghil-mod module)
+ (make <ghil-mod> :module module))
+
+(define-method (ghil-lookup (mod <ghil-mod>) (sym <symbol>))
+ (or (assq-ref mod.table sym)
+ (let ((var (make-ghil-var (env-identifier mod.module) sym 'module)))
+ (set! mod.table (acons sym var mod.table))
+ var)))
+
+
+;;;
+;;; Environments
+;;;
+
+(define-vm-class <ghil-env> ()
+ (mod)
+ (parent #f)
+ (table '())
+ (variables '()))
+
+(define-method (make-ghil-env (m <ghil-mod>))
+ (make <ghil-env> :mod m :parent m))
+
+(define-method (make-ghil-env (e <ghil-env>))
+ (make <ghil-env> :mod e.mod :parent e))
+
+(define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
+ (assq-ref env.table sym))
+
+(define-method (ghil-env-add! (env <ghil-env>) (sym <symbol>) kind)
+ (let ((var (make-ghil-var env sym kind)))
+ (set! env.table (acons sym var env.table))
+ (set! env.variables (cons var env.variables))
+ var))
+
+(define-method (ghil-env-remove! (env <ghil-env>) (sym <symbol>))
+ (set! env.table (assq-remove! env.table sym)))
+
+(define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
+ (or (ghil-env-ref env sym)
+ (let loop ((e env.parent))
+ (cond ((is-a? e <ghil-mod>) (ghil-lookup e sym))
+ ((ghil-env-ref e sym) =>
+ (lambda (var) (set! var.kind 'external) var))
+ (else (loop e.parent))))))
+
+
+;;;
+;;; Parser
+;;;
+
+(define (parse-ghil x e)
+ (parse `(@lambda () ,x) (make-ghil-mod e)))
+
+(define (parse x e)
+ (cond ((pair? x) (parse-pair x e))
+ ((symbol? x)
+ (let ((str (symbol->string x)))
+ (case (string-ref str 0)
+ ((#\@) (error "Invalid use of IL primitive" x))
+ ((#\:) (let ((sym (string->symbol (substring str 1))))
+ (make-<ghil-quote> (symbol->keyword sym))))
+ (else (make-<ghil-ref> e (ghil-lookup e x))))))
+ (else (make-<ghil-quote> x))))
+
+(define (map-parse x e)
+ (map (lambda (x) (parse x e)) x))
+
+(define *macros* (resolve-module '(system il macros)))
+
+(define (parse-pair x e)
+ (let ((head (car x)) (tail (cdr x)))
+ (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
+ (if (module-defined? *macros* head)
+ (parse (apply (module-ref *macros* head) tail) e)
+ (parse-primitive head tail e))
+ (make-<ghil-call> (parse head e) (map-parse tail e)))))
+
+(define (parse-primitive prim args e)
+ (case prim
+ ;; (@ IDENTIFIER)
+ ((@)
+ (match args
+ (()
+ (make-<ghil-ref> e (make-ghil-var '@ '@ 'module)))
+ ((identifier)
+ (receive (module name) (identifier-split identifier)
+ (make-<ghil-ref> e (make-ghil-var module name 'module))))))
+
+ ;; (@@ INST ARGS...)
+ ((@@)
+ (match args
+ ((inst . args)
+ (make-<ghil-inst> inst (map-parse args e)))))
+
+ ;; (@void)
+ ((@void)
+ (match args
+ (() (make-<ghil-void>))))
+
+ ;; (@quote OBJ)
+ ((@quote)
+ (match args
+ ((obj)
+ (make-<ghil-quote> obj))))
+
+ ;; (@define NAME VAL)
+ ((@define)
+ (match args
+ ((name val)
+ (let ((v (ghil-lookup e name)))
+ (make-<ghil-set> e v (parse val e))))))
+
+ ;; (@set! NAME VAL)
+ ((@set!)
+ (match args
+ ((name val)
+ (let ((v (ghil-lookup e name)))
+ (make-<ghil-set> e v (parse val e))))))
+
+ ;; (@if TEST THEN [ELSE])
+ ((@if)
+ (match args
+ ((test then)
+ (make-<ghil-if> (parse test e) (parse then e) (make-<ghil-void>)))
+ ((test then else)
+ (make-<ghil-if> (parse test e) (parse then e) (parse else e)))))
+
+ ;; (@begin BODY...)
+ ((@begin)
+ (parse-body args e))
+
+ ;; (@let ((SYM INIT)...) BODY...)
+ ((@let)
+ (match args
+ ((((sym init) ...) body ...)
+ (let* ((vals (map-parse init e))
+ (vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
+ (body (parse-body body e)))
+ (for-each (lambda (s) (ghil-env-remove! e s)) sym)
+ (make-<ghil-bind> e vars vals body)))))
+
+ ;; (@letrec ((SYM INIT)...) BODY...)
+ ((@letrec)
+ (match args
+ ((((sym init) ...) body ...)
+ (let* ((vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
+ (vals (map-parse init e))
+ (body (parse-body body e)))
+ (for-each (lambda (s) (ghil-env-remove! e s)) sym)
+ (make-<ghil-bind> e vars vals body)))))
+
+ ;; (@lambda FORMALS BODY...)
+ ((@lambda)
+ (match args
+ ((formals . body)
+ (receive (syms rest) (parse-formals formals)
+ (let* ((e (make-ghil-env e))
+ (args (map (lambda (s) (ghil-env-add! e s 'argument)) syms)))
+ (make-<ghil-lambda> e args rest (parse-body body e)))))))
+
+ (else (error "Unknown primitive:" prim))))
+
+(define (parse-body x e)
+ (make-<ghil-begin> (map-parse x e)))
+
+(define (parse-formals formals)
+ (cond
+ ;; (@lambda x ...)
+ ((symbol? formals) (values (list formals) #t))
+ ;; (@lambda (x y z) ...)
+ ((list? formals) (values formals #f))
+ ;; (@lambda (x y . z) ...)
+ ((pair? formals)
+ (let loop ((l formals) (v '()))
+ (if (pair? l)
+ (loop (cdr l) (cons (car l) v))
+ (values (reverse! (cons l v)) #t))))
+ (else (error "Invalid formals:" formals))))
+
+(define (identifier-split identifier)
+ (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+ (if m
+ (values (string->symbol (match:prefix m))
+ (string->symbol (match:substring m 1)))
+ (values #f identifier))))
diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
new file mode 100644
index 000000000..f9eaba9b0
--- /dev/null
+++ b/module/system/il/glil.scm
@@ -0,0 +1,184 @@
+;;; Guile Low Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il glil)
+ :use-module (ice-9 match)
+ :export
+ (pprint-glil
+ make-<glil-asm> <glil-asm>?
+ <glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
+ make-<glil-vars> <glil-vars>? <glil-vars>-1 <glil-vars>-2
+
+ make-<glil-void> <glil-void>?
+ make-<glil-const> <glil-const>? <glil-const>-1
+
+ make-<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
+ make-<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
+ make-<glil-external> <glil-external>?
+ <glil-external>-1 <glil-external>-2 <glil-external>-3
+ make-<glil-module> <glil-module>?
+ <glil-module>-1 <glil-module>-2 <glil-module>-3
+
+ make-<glil-label> <glil-label>? <glil-label>-1
+ make-<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
+ make-<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
+ make-<glil-inst> <glil-inst>? <glil-inst>-1
+ ))
+
+;; Meta operations
+(define-structure (<glil-asm> nargs nrest nlocs nexts body))
+(define-structure (<glil-vars> type syms))
+
+;; Constants
+(define-structure (<glil-void>))
+(define-structure (<glil-const> obj))
+
+;; Variables
+(define-structure (<glil-argument> op index))
+(define-structure (<glil-local> op index))
+(define-structure (<glil-external> op depth index))
+(define-structure (<glil-module> op module name))
+
+;; Controls
+(define-structure (<glil-label> label))
+(define-structure (<glil-branch> inst label))
+(define-structure (<glil-call> inst n))
+(define-structure (<glil-inst> inst))
+
+
+;;;
+;;; Parser
+;;;
+
+;; FIXME: This is not working now
+
+;;; (define (parse-glil x)
+;;; (match x
+;;; (('@asm args . body)
+;;; (let* ((env (make-new-env e))
+;;; (args (parse-args args env)))
+;;; (make-asm env args (map-parse body env))))
+;;; (else
+;;; (error "Invalid assembly code:" x))))
+;;;
+;;; (define (parse-args x e)
+;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
+;;; ((list? x) (make-args (map make-local-var x) #f))
+;;; (else (let loop ((l x) (v '()))
+;;; (if (pair? l)
+;;; (loop (cdr l) (cons (car l) v))
+;;; (make-args (map make-local-var
+;;; (reverse! (cons l v)))
+;;; #t)))))))
+;;; (for-each (lambda (v) (env-add! e v)) (args-vars args))
+;;; args))
+;;;
+;;; (define (map-parse x e)
+;;; (map (lambda (x) (parse x e)) x))
+;;;
+;;; (define (parse x e)
+;;; (match x
+;;; ;; (@asm ARGS BODY...)
+;;; (('@asm args . body)
+;;; (parse-asm x e))
+;;; ;; (@bind VARS BODY...)
+;;; ;; (@block VARS BODY...)
+;;; (((or '@bind '@block) vars . body)
+;;; (let* ((offset (env-nvars e))
+;;; (vars (args-vars (parse-args vars e)))
+;;; (block (make-block (car x) offset vars (map-parse body e))))
+;;; (for-each (lambda (v) (env-remove! e)) vars)
+;;; block))
+;;; ;; (void)
+;;; (('void)
+;;; (make-void))
+;;; ;; (const OBJ)
+;;; (('const obj)
+;;; (make-const obj))
+;;; ;; (ref NAME)
+;;; ;; (set NAME)
+;;; (((or 'ref 'set) name)
+;;; (make-access (car x) (env-ref e name)))
+;;; ;; (label LABEL)
+;;; (('label label)
+;;; (make-label label))
+;;; ;; (br-if LABEL)
+;;; ;; (jump LABEL)
+;;; (((or 'br-if 'jump) label)
+;;; (make-instl (car x) label))
+;;; ;; (call NARGS)
+;;; ;; (tail-call NARGS)
+;;; (((or 'call 'tail-call) n)
+;;; (make-instn (car x) n))
+;;; ;; (INST)
+;;; ((inst)
+;;; (if (instruction? inst)
+;;; (make-inst inst)
+;;; (error "Unknown instruction:" inst)))))
+
+
+;;;
+;;; Unparser
+;;;
+
+(define (unparse glil)
+ (match glil
+ ;; meta
+ (($ <glil-asm> nargs nrest nlocs nexts body)
+ `(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body)))
+ (($ <glil-vars> type syms) `(,type ,@syms))
+ ;; constants
+ (($ <glil-void>) `(void))
+ (($ <glil-const> obj) `(const ,obj))
+ ;; variables
+ (($ <glil-argument> op index)
+ `(,(symbol-append 'argument- op) ,index))
+ (($ <glil-local> op index)
+ `(,(symbol-append 'local- op) ,index))
+ (($ <glil-external> op depth index)
+ `(,(symbol-append 'external- op) ,depth ,index))
+ (($ <glil-module> op module name)
+ `(,(symbol-append 'module- op) ,module ,name))
+ ;; controls
+ (($ <glil-label> label) `(label ,label))
+ (($ <glil-branch> inst label) `(,inst ,label))
+ (($ <glil-call> inst n) `(,inst ,n))
+ (($ <glil-inst> inst) `(,inst))))
+
+
+;;;
+;;; Printer
+;;;
+
+(define (pprint-glil glil)
+ (let print ((code (unparse glil)) (column 0))
+ (display (make-string column #\space))
+ (case (car code)
+ ((@asm)
+ (format #t "(@asm ~A\n" (cadr code))
+ (let ((col (+ column 2)))
+ (let loop ((l (cddr code)))
+ (print (car l) col)
+ (if (null? (cdr l))
+ (display ")")
+ (begin (newline) (loop (cdr l)))))))
+ (else (write code))))
+ (newline))
diff --git a/module/system/il/macros.scm b/module/system/il/macros.scm
new file mode 100644
index 000000000..2897f3e8e
--- /dev/null
+++ b/module/system/il/macros.scm
@@ -0,0 +1,435 @@
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il macros)
+ :use-module (ice-9 match))
+
+(define (make-label) (gensym ":L"))
+(define (make-sym) (gensym "_"))
+
+;;;
+;;; Module macros
+;;;
+
+(define (@import identifier)
+ `((@ System::Base::module::do-import) (@quote ,identifier)))
+
+
+;;;
+;;; Syntax
+;;;
+
+;; (@and X Y...) =>
+;;
+;; (@if X (@and Y...) #f)
+(define @and
+ (match-lambda*
+ (() #t)
+ ((x) x)
+ ((x . rest) `(@if ,x (@and ,@rest) #f))))
+
+;; (@or X Y...) =>
+;;
+;; (@let ((@_ X)) (@if @_ @_ (@or Y...)))
+(define @or
+ (match-lambda*
+ (() #f)
+ ((x) x)
+ ((x . rest)
+ (let ((sym (make-sym)))
+ `(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest)))))))
+
+;; (@while TEST BODY...) =>
+;;
+;; (@goto L1)
+;; L0: BODY...
+;; L1: (@if TEST (@goto L0) (@void))
+;;; non-R5RS
+(define (@while test . body)
+ (let ((L0 (make-label)) (L1 (make-label)))
+ `(@begin
+ (@goto ,L1)
+ (@label ,L0) ,@body
+ (@label ,L1) (@if ,test (@goto ,L0) (@void)))))
+
+;; (@cond (TEST BODY...) ...) =>
+;;
+;; (@if TEST
+;; (@begin BODY...)
+;; (@cond ...))
+(define (@cond . clauses)
+ (cond ((null? clauses) (error "missing clauses"))
+ ((pair? (car clauses))
+ (let ((c (car clauses)) (l (cdr clauses)))
+ (let ((rest (if (null? l) '(@void) `(@cond ,@l))))
+ (cond ((eq? (car c) '@else) `(@begin (@void) ,@(cdr c)))
+ ((null? (cdr c)) `(@or ,(car c) ,rest))
+ (else `(@if ,(car c) (@begin ,@(cdr c)) ,rest))))))
+ (else (error "bad clause:" (car clauses)))))
+
+(define (@let* binds . body)
+ (if (null? binds)
+ `(@begin ,@body)
+ `(@let (,(car binds)) (@let* ,(cdr binds) ,@body))))
+
+
+;;;
+;;; R5RS Procedures
+;;;
+
+;; 6. Standard procedures
+
+;;; 6.1 Equivalence predicates
+
+(define (@eq? x y) `(@@ eq? ,x ,y))
+(define (@eqv? x y) `(@@ eqv? ,x ,y))
+(define (@equal? x y) `(@@ equal? ,x ,y))
+
+;;; 6.2 Numbers
+
+(define (@number? x) `(@@ number? ,x))
+(define (@complex? x) `(@@ complex? ,x))
+(define (@real? x) `(@@ real? ,x))
+(define (@rational? x) `(@@ rational? ,x))
+(define (@integer? x) `(@@ integer? ,x))
+
+(define (@exact? x) `(@@ exact? ,x))
+(define (@inexact? x) `(@@ inexact? ,x))
+
+(define (@= x y) `(@@ ee? ,x ,y))
+(define (@< x y) `(@@ lt? ,x ,y))
+(define (@> x y) `(@@ gt? ,x ,y))
+(define (@<= x y) `(@@ le? ,x ,y))
+(define (@>= x y) `(@@ ge? ,x ,y))
+
+(define (@zero? x) `(@= ,x 0))
+(define (@positive? x) `(@> ,x 0))
+(define (@negative? x) `(@< ,x 0))
+(define (@odd? x) `(@= (@modulo ,x 2) 1))
+(define (@even? x) `(@= (@modulo ,x 2) 0))
+
+(define (@max . args) `(@@ max ,@args))
+(define (@min . args) `(@@ min ,@args))
+
+(define @+
+ (match-lambda*
+ (() 0)
+ ((x) x)
+ ((x y) `(@@ add ,x ,y))
+ ((x y . rest) `(@@ add ,x (@+ ,y ,@rest)))))
+
+(define @*
+ (match-lambda*
+ (() 1)
+ ((x) x)
+ ((x y) `(@@ mul ,x ,y))
+ ((x y . rest) `(@@ mul ,x (@* ,y ,@rest)))))
+
+(define @-
+ (match-lambda*
+ ((x) `(@@ neg ,x))
+ ((x y) `(@@ sub ,x ,y))
+ ((x y . rest) `(@@ sub ,x (@+ ,y ,@rest)))))
+
+(define @/
+ (match-lambda*
+ ((x) `(@@ rec ,x))
+ ((x y) `(@@ div ,x ,y))
+ ((x y . rest) `(@@ div ,x (@* ,y ,@rest)))))
+
+;;; abs
+;;;
+;;; quotient
+(define (@remainder x y) `(@@ remainder ,x ,y))
+;;; modulo
+;;;
+;;; gcd
+;;; lcm
+;;;
+;;; numerator
+;;; denominator
+;;;
+;;; floor
+;;; ceiling
+;;; truncate
+;;; round
+;;;
+;;; rationalize
+;;;
+;;; exp
+;;; log
+;;; sin
+;;; cos
+;;; tan
+;;; asin
+;;; acos
+;;; atan
+;;;
+;;; sqrt
+;;; expt
+;;;
+;;; make-rectangular
+;;; make-polar
+;;; real-part
+;;; imag-part
+;;; magnitude
+;;; angle
+;;;
+;;; exact->inexact
+;;; inexact->exact
+;;;
+;;; number->string
+;;; string->number
+
+;;; 6.3 Other data types
+
+;;;; 6.3.1 Booleans
+
+(define (@not x) `(@@ not ,x))
+(define (@boolean? x) `(@@ boolean? ,x))
+
+;;;; 6.3.2 Pairs and lists
+
+(define (@pair? x) `(@@ pair? ,x))
+(define (@cons x y) `(@@ cons ,x ,y))
+
+(define (@car x) `(@@ car ,x))
+(define (@cdr x) `(@@ cdr ,x))
+(define (@set-car! x) `(@@ set-car! ,x))
+(define (@set-cdr! x) `(@@ set-cdr! ,x))
+
+(define (@caar x) `(@@ car (@@ car ,x)))
+(define (@cadr x) `(@@ car (@@ cdr ,x)))
+(define (@cdar x) `(@@ cdr (@@ car ,x)))
+(define (@cddr x) `(@@ cdr (@@ cdr ,x)))
+(define (@caaar x) `(@@ car (@@ car (@@ car ,x))))
+(define (@caadr x) `(@@ car (@@ car (@@ cdr ,x))))
+(define (@cadar x) `(@@ car (@@ cdr (@@ car ,x))))
+(define (@caddr x) `(@@ car (@@ cdr (@@ cdr ,x))))
+(define (@cdaar x) `(@@ cdr (@@ car (@@ car ,x))))
+(define (@cdadr x) `(@@ cdr (@@ car (@@ cdr ,x))))
+(define (@cddar x) `(@@ cdr (@@ cdr (@@ car ,x))))
+(define (@cdddr x) `(@@ cdr (@@ cdr (@@ cdr ,x))))
+(define (@caaaar x) `(@@ car (@@ car (@@ car (@@ car ,x)))))
+(define (@caaadr x) `(@@ car (@@ car (@@ car (@@ cdr ,x)))))
+(define (@caadar x) `(@@ car (@@ car (@@ cdr (@@ car ,x)))))
+(define (@caaddr x) `(@@ car (@@ car (@@ cdr (@@ cdr ,x)))))
+(define (@cadaar x) `(@@ car (@@ cdr (@@ car (@@ car ,x)))))
+(define (@cadadr x) `(@@ car (@@ cdr (@@ car (@@ cdr ,x)))))
+(define (@caddar x) `(@@ car (@@ cdr (@@ cdr (@@ car ,x)))))
+(define (@cadddr x) `(@@ car (@@ cdr (@@ cdr (@@ cdr ,x)))))
+(define (@cdaaar x) `(@@ cdr (@@ car (@@ car (@@ car ,x)))))
+(define (@cdaadr x) `(@@ cdr (@@ car (@@ car (@@ cdr ,x)))))
+(define (@cdadar x) `(@@ cdr (@@ car (@@ cdr (@@ car ,x)))))
+(define (@cdaddr x) `(@@ cdr (@@ car (@@ cdr (@@ cdr ,x)))))
+(define (@cddaar x) `(@@ cdr (@@ cdr (@@ car (@@ car ,x)))))
+(define (@cddadr x) `(@@ cdr (@@ cdr (@@ car (@@ cdr ,x)))))
+(define (@cdddar x) `(@@ cdr (@@ cdr (@@ cdr (@@ car ,x)))))
+(define (@cddddr x) `(@@ cdr (@@ cdr (@@ cdr (@@ cdr ,x)))))
+
+(define (@null? x) `(@@ null? ,x))
+(define (@list? x) `(@@ list? ,x))
+(define (@list . args) `(@@ list ,@args))
+
+;;; length
+;;; append
+;;; reverse
+;;; list-tail
+;;; list-ref
+;;;
+;;; memq
+;;; memv
+;;; member
+;;;
+;;; assq
+;;; assv
+;;; assoc
+
+;;;; 6.3.3 Symbols
+
+;;; symbol?
+;;; symbol->string
+;;; string->symbol
+
+;;;; 6.3.4 Characters
+
+;;; char?
+;;; char=?
+;;; char<?
+;;; char>?
+;;; char<=?
+;;; char>=?
+;;; char-ci=?
+;;; char-ci<?
+;;; char-ci>?
+;;; char-ci<=?
+;;; char-ci>=?
+;;; char-alphabetic?
+;;; char-numeric?
+;;; char-whitespace?
+;;; char-upper-case?
+;;; char-lower-case?
+;;; char->integer
+;;; integer->char
+;;; char-upcase
+;;; char-downcase
+
+;;;; 6.3.5 Strings
+
+;;; string?
+;;; make-string
+;;; string
+;;; string-length
+;;; string-ref
+;;; string-set!
+;;;
+;;; string=?
+;;; string-ci=?
+;;; string<?
+;;; string>?
+;;; string<=?
+;;; string>=?
+;;; string-ci<?
+;;; string-ci>?
+;;; string-ci<=?
+;;; string-ci>=?
+;;;
+;;; substring
+;;; string-append
+;;; string->list
+;;; list->string
+;;; string-copy
+;;; string-fill!
+
+;;;; 6.3.6 Vectors
+
+;;; vector?
+;;; make-vector
+;;; vector
+;;; vector-length
+;;; vector-ref
+;;; vector-set!
+;;; vector->list
+;;; list->vector
+;;; vector-fill!
+
+;;;; 6.4 Control features
+
+(define (@procedure? x) `(@@ procedure? x))
+
+;; (define (@apply proc . args) ...)
+
+(define (@map f ls . more)
+ (if (null? more)
+ `(@let ((f ,f))
+ (@let map1 ((ls ,ls))
+ (@if (@null? ls)
+ '()
+ (@cons (f (car ls)) (map1 (cdr ls))))))
+ `(@let ((f ,f))
+ (@let map-more ((ls ,ls) (more ,more))
+ (@if (@null? ls)
+ '()
+ (@cons (@apply f (car ls) (map car more))
+ (map-more (cdr ls) (map cdr more))))))))
+
+(define @for-each
+ (match-lambda*
+ ((f l)
+ (do ((ls ls (cdr ls)) (more more (map cdr more)))
+ ((null? ls))
+ (apply f (car ls) (map car more))))
+ ((f . args)
+ `(@apply (@~ system:il:base:for-each) args))))
+
+(define (@force promise) `(@@ force promise))
+
+(define (@call-with-current-continuation proc) `(@@ call/cc proc))
+
+(define @call/cc @call-with-current-continuation)
+
+;;; values
+;;; call-with-values
+;;; dynamic-wind
+
+;;; 6.5 Eval
+
+;;; eval
+;;; scheme-report-environment
+;;; null-environment
+;;; interaction-environment
+
+;;; 6.6 Input and output
+
+;;;; 6.6.1 Ports
+
+;;; call-with-input-file
+;;; call-with-output-file
+;;;
+;;; input-port?
+;;; output-port?
+;;; current-input-port
+;;; current-output-port
+;;;
+;;; with-input-from-file
+;;; with-output-to-file
+;;;
+;;; open-input-file
+;;; open-output-file
+;;; close-input-port
+;;; close-output-port
+
+;;;; 6.6.2 Input
+
+;;; read
+;;; read-char
+;;; peek-char
+;;; eof-object?
+;;; char-ready?
+
+;;;; 6.6.3 Output
+
+;;; write
+;;; display
+;;; newline
+;;; write-char
+
+;;;; 6.6.4 System interface
+
+;;; load
+;;; transcript-on
+;;; transcript-off
+
+
+;;;
+;;; Non-R5RS Procedures
+;;;
+
+(define @cons*
+ (match-lambda*
+ ((x) x)
+ ((x y) `(@cons ,x ,y))
+ ((x y . rest) `(@cons ,x (@cons* ,y ,@rest)))))
+
+(define (@error . args) `(@@ display ,@args))
+
+(define (@current-module)
+ `((@ System::Base::module::current-module)))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
new file mode 100644
index 000000000..c18016fc4
--- /dev/null
+++ b/module/system/repl/command.scm
@@ -0,0 +1,506 @@
+;;; command.scm --- REPL commands
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl command)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system base language)
+ :use-module (system repl common)
+ :use-module (system il glil)
+ :use-module (system vm core)
+ :use-module (system vm trace)
+ :use-module (system vm disasm)
+ :use-module (system vm profile)
+ :use-module (ice-9 format)
+ :use-module (ice-9 session)
+ :use-module (ice-9 debugger)
+ :export (meta-command))
+
+(define (puts x) (display x) (newline))
+
+(define (user-error msg . args)
+ (throw 'user-error #f msg args #f))
+
+
+;;;
+;;; Meta command
+;;;
+
+(define *command-table*
+ '((help (help h) (apropos a) (describe d) (option o) (quit q))
+ (module (module m) (use u) (import i) (load l) (binding b) (lsmod lm))
+ (package (package p) (lspkg lp) (autopackage) (globals g))
+ (language (language L))
+ (compile (compile c) (compile-file cc)
+ (disassemble x) (disassemble-file xx))
+ (profile (time t) (profile pr))
+ (debug (backtrace bt) (debugger db) (trace tr) (step st))
+ (system (statistics stat) (gc))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+(define *command-module* (current-module))
+(define (command-name c) (car c))
+(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (command-usage c)
+ (let ((doc (command-doc c)))
+ (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+ (let* ((doc (command-doc c))
+ (start (1+ (string-index doc #\newline))))
+ (cond ((string-index doc #\newline start)
+ => (lambda (end) (substring doc start end)))
+ (else (substring doc start)))))
+
+(define (lookup-group name)
+ (assq name *command-table*))
+
+(define (lookup-command key)
+ (let loop ((groups *command-table*) (commands '()))
+ (cond ((and (null? groups) (null? commands)) #f)
+ ((null? commands)
+ (loop (cdr groups) (cdar groups)))
+ ((memq key (car commands)) (car commands))
+ (else (loop groups (cdr commands))))))
+
+(define (display-group group . opts)
+ (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+ (for-each (lambda (c)
+ (display-summary (command-usage c)
+ (command-abbrev c)
+ (command-summary c)))
+ (group-commands group))
+ (newline))
+
+(define (display-command command)
+ (display "Usage: ")
+ (display (command-doc command))
+ (newline))
+
+(define (display-summary usage abbrev summary)
+ (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+ (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+
+(define (meta-command repl line)
+ (let ((input (call-with-input-string (string-append "(" line ")") read)))
+ (if (not (null? input))
+ (do ((key (car input))
+ (args (cdr input) (cdr args))
+ (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+ ((or (null? args)
+ (not (symbol? (car args)))
+ (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+ (let ((c (lookup-command key)))
+ (if c
+ (cond ((memq :h opts) (display-command c))
+ (else (apply (command-procedure c)
+ repl (append! args opts))))
+ (user-error "Unknown meta command: ~A" key))))))))
+
+
+;;;
+;;; Help commands
+;;;
+
+(define (help repl . args)
+ "help [GROUP]
+Show help messages.
+The optional argument can be either one of command groups or
+command names. Without argument, a list of help commands and
+all command groups are displayed, as you have already seen :)"
+ (match args
+ (()
+ (display-group (lookup-group 'help))
+ (display "Command Groups:\n\n")
+ (display-summary "help all" #f "List all commands")
+ (for-each (lambda (g)
+ (let* ((name (symbol->string (group-name g)))
+ (usage (string-append "help " name))
+ (header (string-append "List " name " commands")))
+ (display-summary usage #f header)))
+ (cdr *command-table*))
+ (newline)
+ (display "Enter `,COMMAND -h' to display documentation of each command.")
+ (newline))
+ (('all)
+ (for-each display-group *command-table*))
+ ((? lookup-group group)
+ (display-group (lookup-group group)))
+ (else (user-error "Unknown command group: ~A" (car args)))))
+
+(define guile-apropos apropos)
+(define (apropos repl regexp)
+ "apropos [options] REGEXP
+Find bindings/modules/packages."
+ (guile-apropos (object->string regexp display)))
+
+(define (describe repl obj)
+ "describe OBJ
+Show description/documentation."
+ (display "Not implemented yet\n"))
+
+(define (option repl . args)
+ "option [KEY [VALUE]]
+List/show/set options."
+ (display "Not implemented yet\n"))
+
+(define (quit repl)
+ "quit
+Quit this session."
+ (throw 'quit))
+
+
+;;;
+;;; Module commands
+;;;
+
+(define (module repl . args)
+ "module [MODULE]
+Change modules / Show current module."
+ (match args
+ (() (puts (binding repl.module)))))
+
+(define (use repl . args)
+ "use [MODULE ...]
+Use modules."
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! repl.module mod)
+ (user-error "No such module: ~A" name))))
+ (if (null? args)
+ (for-each puts (map module-name
+ (cons repl.module (module-uses repl.module))))
+ (for-each (lambda (name)
+ (cond
+ ((pair? name) (use name))
+ ((symbol? name)
+ (cond ((find-one-module (symbol->string name)) => use)))
+ (else (user-error "Invalid module name: ~A" name))))
+ args)))
+
+(define (import repl . args)
+ "import [MODULE ...]
+Import modules / List those imported."
+ (define (use name)
+ (let ((mod (resolve-interface name)))
+ (if mod
+ (module-use! repl.module mod)
+ (user-error "No such module: ~A" name))))
+ (if (null? args)
+ (for-each puts (map module-name
+ (cons repl.module (module-uses repl.module))))
+ (for-each (lambda (name)
+ (cond
+ ((pair? name) (use name))
+ ((symbol? name)
+ (and-let* ((m (find-one-module (symbol->string name))))
+ (puts m) (use m)))
+ (else (user-error "Invalid module name: ~A" name))))
+ args)))
+
+(define (load repl file . opts)
+ "load [options] FILE
+Load a file in the current module."
+ (apply repl-load-file repl (->string file) opts))
+
+(define (binding repl . opts)
+ "binding [-a]
+List current bindings."
+ (fold (lambda (s v d) (format #t "~23A ~A\n" s v)) #f repl.module))
+
+(define (lsmod repl . args)
+ "lsmod
+."
+ (define (use name)
+ (set! repl.module (resolve-module name))
+ (module-use! repl.module repl.value-history))
+ (if (null? args)
+ (use '(guile-user))
+ (let ((name (car args)))
+ (cond
+ ((pair? name) (use name))
+ ((symbol? name)
+ (and-let* ((m (find-one-module (symbol->string name))))
+ (puts m) (use m)))
+ (else (user-error "Invalid module name: ~A" name))))))
+
+
+;;;
+;;; Package commands
+;;;
+
+(define (package repl)
+ "package [PACKAGE]
+List available packages/modules."
+ (for-each puts (find-module "")))
+
+(define (lspkg repl)
+ "lspkg
+List available packages/modules."
+ (for-each puts (find-module "")))
+
+(define (autopackage repl)
+ "autopackage
+List available packages/modules."
+ (for-each puts (find-module "")))
+
+(define (globals repl)
+ "globals
+List all global variables."
+ (global-fold (lambda (s v d) (format #t "~A\t~S\n" s v)) #f))
+
+
+;;;
+;;; Language commands
+;;;
+
+(define (language repl name)
+ "language LANGUAGE
+Change languages."
+ (set! repl.language (lookup-language name))
+ (repl-welcome repl))
+
+
+;;;
+;;; Compile commands
+;;;
+
+(define (compile repl form . opts)
+ "compile [options] FORM
+Generate compiled code.
+
+ -e Stop after expanding syntax/macro
+ -t Stop after translating into GHIL
+ -c Stop after generating GLIL
+ -l Stop before linking
+ -o Compile into bytecode
+
+ -O Enable optimization
+ -D Add debug information"
+ (let ((x (apply repl-compile repl form opts)))
+ (cond ((null? opts)
+ (disassemble-program x))
+ ((memq :l opts)
+ (disassemble-bytecode x))
+ ((memq :c opts)
+ (pprint-glil x))
+ (else
+ (puts x)))))
+
+(define (compile-file repl file . opts)
+ "compile-file [options] FILE
+Compile a file."
+ (apply repl-compile-file repl (->string file) opts))
+
+(define (disassemble repl prog)
+ "disassemble PROGRAM
+Disassemble a program."
+ (disassemble-program (repl.vm (repl-compile repl prog))))
+
+(define (disassemble-file repl file)
+ "disassemble-file FILE
+Disassemble a file."
+ (disassemble-bytecode (load-file-in (->string file)
+ repl.module
+ repl.language)))
+
+(define (->string x)
+ (object->string x display))
+
+
+;;;
+;;; Profile commands
+;;;
+
+(define (profile repl form . opts)
+ "profile FORM
+Profile execution."
+ (apply vm-profile repl.vm (repl-compile repl form) opts))
+
+
+;;;
+;;; Debug commands
+;;;
+
+(define guile-backtrace backtrace)
+(define (backtrace repl)
+ "backtrace
+Show backtrace (if any)."
+ (guile-backtrace))
+
+(define (debugger repl)
+ "debugger
+Start debugger."
+ (debug))
+
+(define (trace repl form . opts)
+ "trace [-a] FORM
+Trace execution."
+ (apply vm-trace repl.vm (repl-compile repl form) opts))
+
+(define (step repl)
+ "step FORM
+Step execution."
+ (display "Not implemented yet\n"))
+
+
+;;;
+;;; System commands
+;;;
+
+(define (time repl form)
+ "time FORM
+Time execution."
+ (let* ((vms-start (vm-stats repl.vm))
+ (gc-start (gc-run-time))
+ (tms-start (times))
+ (result (repl-eval repl form))
+ (tms-end (times))
+ (gc-end (gc-run-time))
+ (vms-end (vm-stats repl.vm)))
+ (define (get proc start end)
+ (/ (- (proc end) (proc start)) internal-time-units-per-second))
+ (repl-print repl result)
+ (display "clock utime stime cutime cstime gctime\n")
+ (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+ (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))
+
+;;;
+;;; Statistics
+;;;
+
+(define guile-gc gc)
+(define (gc repl)
+ "gc
+Garbage collection."
+ (guile-gc))
+
+(define (display-stat title flag field1 field2 unit)
+ (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+ (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+ (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+ (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+ (define (conv num)
+ (format #f "~10,2F" (/ num internal-time-units-per-second)))
+ (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+ (define (mips time clock)
+ (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
+ (display-stat title #f
+ (mips (- this-time last-time) (- this-clock last-clock))
+ (mips this-time this-clock) "mips"))
+
+(define (statistics repl)
+ "statistics
+Display statistics."
+ (let ((this-tms (times))
+ (this-vms (vm-stats repl.vm))
+ (this-gcs (gc-stats))
+ (last-tms repl.tm-stats)
+ (last-vms repl.vm-stats)
+ (last-gcs repl.gc-stats))
+ ;; GC times
+ (let ((this-times (assq-ref this-gcs 'gc-times))
+ (last-times (assq-ref last-gcs 'gc-times)))
+ (display-diff-stat "GC times:" #t this-times last-times "times")
+ (newline))
+ ;; Memory size
+ (let ((this-cells (assq-ref this-gcs 'cells-allocated))
+ (this-heap (assq-ref this-gcs 'cell-heap-size))
+ (this-bytes (assq-ref this-gcs 'bytes-malloced))
+ (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+ (display-stat-title "Memory size:" "current" "limit")
+ (display-stat "heap" #f this-cells this-heap "cells")
+ (display-stat "malloc" #f this-bytes this-malloc "bytes")
+ (newline))
+ ;; Cells collected
+ (let ((this-marked (assq-ref this-gcs 'cells-marked))
+ (last-marked (assq-ref last-gcs 'cells-marked))
+ (this-swept (assq-ref this-gcs 'cells-swept))
+ (last-swept (assq-ref last-gcs 'cells-swept)))
+ (display-stat-title "Cells collected:" "diff" "total")
+ (display-diff-stat "marked" #f this-marked last-marked "cells")
+ (display-diff-stat "swept" #f this-swept last-swept "cells")
+ (newline))
+ ;; GC time taken
+ (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
+ (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
+ (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
+ (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
+ (this-total (assq-ref this-gcs 'gc-time-taken))
+ (last-total (assq-ref last-gcs 'gc-time-taken)))
+ (display-stat-title "GC time taken:" "diff" "total")
+ (display-time-stat "mark" this-mark last-mark)
+ (display-time-stat "sweep" this-sweep last-sweep)
+ (display-time-stat "total" this-total last-total)
+ (newline))
+ ;; Process time spent
+ (let ((this-utime (tms:utime this-tms))
+ (last-utime (tms:utime last-tms))
+ (this-stime (tms:stime this-tms))
+ (last-stime (tms:stime last-tms))
+ (this-cutime (tms:cutime this-tms))
+ (last-cutime (tms:cutime last-tms))
+ (this-cstime (tms:cstime this-tms))
+ (last-cstime (tms:cstime last-tms)))
+ (display-stat-title "Process time spent:" "diff" "total")
+ (display-time-stat "user" this-utime last-utime)
+ (display-time-stat "system" this-stime last-stime)
+ (display-time-stat "child user" this-cutime last-cutime)
+ (display-time-stat "child system" this-cstime last-cstime)
+ (newline))
+ ;; VM statistics
+ (let ((this-time (vms:time this-vms))
+ (last-time (vms:time last-vms))
+ (this-clock (vms:clock this-vms))
+ (last-clock (vms:clock last-vms)))
+ (display-stat-title "VM statistics:" "diff" "total")
+ (display-time-stat "time spent" this-time last-time)
+ (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
+ (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
+ (newline))
+ ;; Save statistics
+ ;; Save statistics
+ (set! repl.tm-stats this-tms)
+ (set! repl.vm-stats this-vms)
+ (set! repl.gc-stats this-gcs)))
+
+;;; repl.scm ends here
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
new file mode 100644
index 000000000..4e0753593
--- /dev/null
+++ b/module/system/repl/common.scm
@@ -0,0 +1,93 @@
+;;; common.scm --- Repl common routines
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl common)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system base language)
+ :use-module (system vm core)
+ :export (make-repl repl-welcome repl-prompt repl-read repl-compile
+ repl-eval repl-print repl-compile-file repl-load-file))
+
+
+;;;
+;;; Repl
+;;;
+
+(define-vm-class <repl> ()
+ vm language module value-count value-history tm-stats vm-stats gc-stats)
+
+(define (make-repl lang)
+ (let ((vm (make-vm)))
+ (make <repl>
+ :vm vm
+ :language (lookup-language lang)
+ :module (global-ref 'user)
+ :value-count 0
+; :value-history (make-vmodule)
+ :tm-stats (times)
+ :vm-stats (vm-stats vm)
+ :gc-stats (gc-stats))))
+
+(define (repl-welcome repl)
+ (format #t "~A interpreter ~A on Guile ~A\n"
+ repl.language.title repl.language.version (version))
+ (display "Copyright (C) 2001 Free Software Foundation, Inc.\n\n")
+ (display "Enter `,help' for help.\n"))
+
+(define (repl-prompt repl)
+ (format #t "~A@~A> " repl.language.name (env-identifier repl.module))
+ (force-output))
+
+(define (repl-read repl . args)
+ (apply read-in repl.language args))
+
+(define (repl-compile repl form . opts)
+ (let ((bytes (apply compile-in form repl.module repl.language opts)))
+ (if (or (memq :c opts) (memq :l opts))
+ bytes
+ (vm-load repl.vm bytes))))
+
+(define (repl-eval repl form)
+ (let ((evaler repl.language.evaler))
+ (if evaler
+ (evaler form repl.module)
+ (repl.vm (repl-compile repl form)))))
+
+(define (repl-print repl val)
+ (if (not (eq? val *unspecified*))
+ (let* ((num (1+ repl.value-count))
+ (sym (string->symbol (format #f "$~A" num))))
+; (vmodule-define repl.value-history sym val)
+ (format #t "~A = " sym)
+ (print-in val repl.language)
+ (newline)
+ (set! repl.value-count num))))
+
+(define (repl-compile-file repl form . opts)
+ (apply compile-file-in form repl.module repl.language opts))
+
+(define (repl-load-file repl file . opts)
+ (let ((bytes (apply load-file-in file repl.module repl.language opts)))
+ (repl.vm (vm-load repl.vm bytes))))
+
+;;; common.scm ends here
diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm
new file mode 100644
index 000000000..17e46621f
--- /dev/null
+++ b/module/system/repl/describe.scm
@@ -0,0 +1,364 @@
+;;; describe.scm --- describe objects
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl describe)
+ :use-module (oop goops)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 format))
+
+(define *describe-format* #t)
+
+(define-public (describe symbol)
+ (assert symbol? symbol)
+ (format #t "`~s' is " symbol)
+ (if (not (defined? symbol))
+ (display "not defined in the current module.\n")
+ (describe-object (eval symbol))))
+
+
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+ (if (slot-bound? class 'name)
+ (class-name class)
+ class))
+
+(define-method (display-class class . args)
+ (let* ((name (safe-class-name class))
+ (desc (if (pair? args) (car args) name)))
+ (if (eq? *describe-format* 'tag)
+ (format #t "@class{~a}{~a}" name desc)
+ (format #t "~a" desc))))
+
+(define-public (display-list title list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each display-summary list)))
+
+(define-public (display-slot-list title instance list)
+ (if title (begin (display title) (display ":\n\n")))
+ (if (null? list)
+ (display "(not defined)\n")
+ (for-each (lambda (slot)
+ (let ((name (slot-definition-name slot)))
+ (display "Slot: ")
+ (display name)
+ (if (and instance (slot-bound? instance name))
+ (begin
+ (display " = ")
+ (display (slot-ref instance name))))
+ (newline)))
+ list)))
+
+(define-public (display-file location)
+ (display "Defined in ")
+ (if (eq? *describe-format* 'tag)
+ (format #t "@location{~a}.\n" location)
+ (format #t "`~a'.\n" location)))
+
+(define-public (format-documentation doc)
+ (with-current-buffer (make-buffer #:text doc)
+ (lambda ()
+ (let ((regexp (make-regexp "@([a-z]*)(\\{([^\}]*)\\})?")))
+ (do-while (match (re-search-forward regexp))
+ (let ((key (string->symbol (match:substring match 1)))
+ (value (match:substring match 3)))
+ (case key
+ ((deffnx)
+ (delete-region! (match:start match)
+ (begin (forward-line) (point))))
+ ((var)
+ (replace-match! match 0 (string-upcase value)))
+ ((code)
+ (replace-match! match 0 (string-append "`" value "'")))))))
+ (display (string (current-buffer)))
+ (newline))))
+
+
+;;;
+;;; Top
+;;;
+
+(define description-table
+ (list
+ (cons <boolean> "a boolean")
+ (cons <null> "an empty list")
+ (cons <integer> "an integer")
+ (cons <real> "a real number")
+ (cons <complex> "a complex number")
+ (cons <char> "a character")
+ (cons <symbol> "a symbol")
+ (cons <keyword> "a keyword")
+ (cons <promise> "a promise")
+ (cons <hook> "a hook")
+ (cons <fluid> "a fluid")
+ (cons <stack> "a stack")
+ (cons <variable> "a variable")
+ (cons <regexp> "a regexp object")
+ (cons <module> "a module object")
+ (cons <unknown> "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-value obj)
+ (newline)
+ (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+ display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+ (write obj))
+
+(define-method (display-summary (obj <top>))
+ (display "Value: ")
+ (display-object obj)
+ (newline))
+
+(define-method (display-type (obj <top>))
+ (cond
+ ((eof-object? obj) (display "the end-of-file object"))
+ ((unspecified? obj) (display "unspecified"))
+ (else (let ((class (class-of obj)))
+ (display-class class (or (assq-ref description-table class)
+ (safe-class-name class))))))
+ (display ".\n"))
+
+(define-method (display-value (obj <top>))
+ (if (not (unspecified? obj))
+ (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+ *unspecified*)
+
+(define-method (display-description (obj <top>))
+ (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+ (index (string-index doc #\newline)))
+ (display (make-shared-substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+ (display "Not documented.\n"))
+
+
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+ (cond
+ ((list? obj) (display-class <list> "a list"))
+ ((pair? (cdr obj)) (display "an improper list"))
+ (else (display-class <pair> "a pair")))
+ (display ".\n"))
+
+
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+ (if (read-only-string? 'obj)
+ (display "a read-only string")
+ (display-class <string> "a string"))
+ (display ".\n"))
+
+
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+ (cond
+ ((closure? obj)
+ ;; Construct output from the source.
+ (display "(")
+ (display (procedure-name obj))
+ (let ((args (cadr (procedure-source obj))))
+ (cond ((null? args) (display ")"))
+ ((pair? args)
+ (let ((str (with-output-to-string (lambda () (display args)))))
+ (format #t " ~a" (string-upcase! (substring str 1)))))
+ (else
+ (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+ (else
+ ;; Primitive procedure. Let's lookup the dictionary.
+ (and-let* ((entry (lookup-procedure obj)))
+ (let ((name (entry-property entry 'name))
+ (print-arg (lambda (arg)
+ (display " ")
+ (display (string-upcase (symbol->string arg))))))
+ (display "(")
+ (display name)
+ (and-let* ((args (entry-property entry 'args)))
+ (for-each print-arg args))
+ (and-let* ((opts (entry-property entry 'opts)))
+ (display " &optional")
+ (for-each print-arg opts))
+ (and-let* ((rest (entry-property entry 'rest)))
+ (display " &rest")
+ (print-arg rest))
+ (display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+ (display "Procedure: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+ (cond
+ ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+ ((closure? obj) (display-class <procedure> "a procedure"))
+ ((procedure-with-setter? obj)
+ (display-class <procedure-with-setter> "a procedure with setter"))
+ ((not (struct? obj)) (display "a primitive procedure"))
+ (else (display-class <procedure> "a procedure")))
+ (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+ (and-let* ((entry (lookup-procedure obj)))
+ (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+ (cond ((cond ((closure? obj) (procedure-documentation obj))
+ ((lookup-procedure obj) => entry-text)
+ (else #f))
+ => format-documentation)
+ (else (next-method))))
+
+
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+ (display-type obj)
+ (display-location obj)
+ (newline)
+ (display-documentation obj)
+ (newline)
+ (display-value obj))
+
+(define-method (display-summary (obj <class>))
+ (display "Class: ")
+ (display-class obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <class>))
+ (display-class <class> "a class")
+ (if (not (eq? (class-of obj) <class>))
+ (begin (display " of ") (display-class (class-of obj))))
+ (display ".\n"))
+
+(define-method (display-value (obj <class>))
+ (display-list "Class precedence list" (class-precedence-list obj))
+ (newline)
+ (display-list "Direct superclasses" (class-direct-supers obj))
+ (newline)
+ (display-list "Direct subclasses" (class-direct-subclasses obj))
+ (newline)
+ (display-slot-list "Direct slots" #f (class-direct-slots obj))
+ (newline)
+ (display-list "Direct methods" (class-direct-methods obj)))
+
+
+;;;
+;;; Instances
+;;;
+
+(define-method display-type ((obj <object>))
+ (display-class <object> "an instance")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method display-value ((obj <object>))
+ (display-slot-list #f obj (class-slots (class-of obj))))
+
+
+;;;
+;;; Generic functions
+;;;
+
+(define-method display-type ((obj <generic>))
+ (display-class <generic> "a generic function")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method display-value ((obj <generic>))
+ (display-list #f (generic-function-methods obj)))
+
+
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+ (display "(")
+ (let ((gf (method-generic-function obj)))
+ (display (if gf (generic-function-name gf) "#<anonymous>")))
+ (let loop ((args (method-specializers obj)))
+ (cond
+ ((null? args))
+ ((pair? args)
+ (display " ")
+ (display-class (car args))
+ (loop (cdr args)))
+ (else (display " . ") (display-class args))))
+ (display ")"))
+
+(define-method (display-summary (obj <method>))
+ (display "Method: ")
+ (display-object obj)
+ (newline)
+ (display " ")
+ (display-description obj))
+
+(define-method (display-type (obj <method>))
+ (display-class <method> "a method")
+ (display " of class ")
+ (display-class (class-of obj))
+ (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+ (let ((doc (procedure-documentation (method-procedure obj))))
+ (if doc (format-documentation doc) (next-method))))
+
+;;; describe.scm ends here
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
new file mode 100644
index 000000000..8fbe50e4d
--- /dev/null
+++ b/module/system/repl/repl.scm
@@ -0,0 +1,74 @@
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl repl)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system repl common)
+ :use-module (system repl command)
+ :use-module (system vm frame)
+ :use-module (ice-9 rdelim)
+ :export (start-repl))
+
+(define (start-repl lang)
+ (let ((repl (make-repl lang)))
+ (set-current-vmodule! repl.module)
+ (set-current-evaluator! repl.vm)
+ (repl-welcome repl)
+ (let prompt-loop ()
+ (repl-prompt repl)
+ (call-with-error-handlers
+ (lambda ()
+ (if (eq? (next-char #t) #\,)
+ ;; meta command
+ (begin (read-char)
+ (meta-command repl (read-line)))
+ ;; evaluation
+ (let rep-loop ()
+ (repl-print repl (repl-eval repl (repl-read repl)))
+ (if (next-char #f) (rep-loop))))))
+ (prompt-loop))))
+
+(define (next-char wait)
+ (if (or wait (char-ready?))
+ (let ((ch (peek-char)))
+ (cond ((eof-object? ch) (throw 'quit))
+ ((char-whitespace? ch) (read-char) (next-char wait))
+ (else ch)))
+ #f))
+
+;;;
+;;; Error handler
+;;;
+
+(define (call-with-error-handlers thunk)
+ (catch 'vm-error
+ (lambda () (catch 'user-error thunk error-handler))
+ error-handler))
+
+(define (error-handler key . args)
+ (case key
+ ((vm-error)
+ (write (frame->call (cadddr args)))
+ (newline)))
+ (display "ERROR: ")
+ (apply format #t (cadr args) (caddr args))
+ (newline))
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
new file mode 100644
index 000000000..dfddf5c28
--- /dev/null
+++ b/module/system/vm/assemble.scm
@@ -0,0 +1,327 @@
+;;; Guile VM assembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm assemble)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system il glil)
+ :use-module (system vm core)
+ :use-module (system vm conv)
+ :use-module (ice-9 match)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 common-list)
+ :export (assemble))
+
+(define (assemble glil env . opts)
+ (dump (codegen (preprocess glil #f) #t)))
+
+
+;;;
+;;; Types
+;;;
+
+(define-structure (<vm-asm> venv glil body))
+(define-structure (venv parent nexts closure?))
+(define-structure (vmod id))
+(define-structure (vlink module name))
+(define-structure (bytespec nargs nrest nlocs bytes objs))
+
+
+;;;
+;;; Stage 1: Preprocess
+;;;
+
+(define (preprocess x e)
+ (match x
+ (($ <glil-asm> nargs nrest nlocs nexts body)
+ (let* ((venv (make-venv e nexts #f))
+ (body (map (lambda (x) (preprocess x venv)) body)))
+ (make-<vm-asm> venv x body)))
+ (($ <glil-external> op depth index)
+ (do ((d depth (1- d))
+ (e e (venv-parent e)))
+ ((= d 0))
+ (set-venv-closure?! e #t))
+ x)
+ (else x)))
+
+
+;;;
+;;; Stage 2: Bytecode generation
+;;;
+
+(define (codegen glil toplevel)
+ (match glil
+ (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
+ (let ((stack '())
+ (label-alist '())
+ (object-alist '())
+ (nvars (+ nargs nlocs -1)))
+ (define (current-address) (length stack))
+ (define (push-code! code)
+ (set! stack (optimizing-push code stack)))
+ (define (object-index obj)
+ (cond ((assq-ref object-alist obj))
+ (else (let ((index (length object-alist)))
+ (set! object-alist (acons obj index object-alist))
+ index))))
+ (define (label-ref key)
+ (assq-ref label-alist key))
+ (define (label-set key pos)
+ (set! label-alist (assq-set! label-alist key pos)))
+ (define (generate-code x)
+ (match x
+ (($ <vm-asm> env)
+ (push-code! `(object-ref ,(object-index (codegen x #f))))
+ (if (venv-closure? env) (push-code! `(make-closure))))
+
+ (($ <glil-void>)
+ (push-code! `(void)))
+
+ (($ <glil-const> x)
+ (if toplevel
+ (for-each push-code! (object->dump-code x))
+ (cond ((object->code x) => push-code!)
+ (else (push-code! `(object-ref ,(object-index x)))))))
+
+ (($ <glil-argument> op index)
+ (push-code! (list (symbol-append 'local- op)
+ (- nvars index))))
+
+ (($ <glil-local> op index)
+ (push-code! (list (symbol-append 'local- op)
+ (- nvars (+ nargs index)))))
+
+ (($ <glil-external> op depth index)
+ (do ((e venv (venv-parent e))
+ (d depth (1- d))
+ (i 0 (+ i (venv-nexts e))))
+ ((= d 0)
+ (push-code! (list (symbol-append 'external- op)
+ (+ index i))))))
+
+ (($ <glil-module> op module name)
+ (let ((mod (make-vmod module)))
+ (if toplevel
+ (begin
+ (push-code! `(load-module ,module))
+ (push-code! `(load-symbol ,name))
+ (push-code! `(link)))
+ (let ((vlink (make-vlink mod name)))
+ (push-code! `(object-ref ,(object-index vlink)))))
+ (push-code! (list (symbol-append 'variable- op)))))
+
+ (($ <glil-label> label)
+ (label-set label (current-address)))
+
+ (($ <glil-branch> inst label)
+ (let ((setter (lambda (addr) (- (label-ref label) (1+ addr)))))
+ (push-code! (list inst setter))))
+
+ (($ <glil-call> inst n)
+ (push-code! (list inst n)))
+
+ (($ <glil-inst> inst)
+ (if (instruction? inst)
+ (push-code! (list inst))
+ (error "Unknown instruction:" inst)))))
+ ;;
+ ;; main
+ (if (> nexts 0) (push-code! `(external ,nexts)))
+ (for-each generate-code body)
+ (let ((bytes (code->bytes
+ (map/index (lambda (v n) (if (procedure? v) (v n) v))
+ (reverse! stack))))
+ (objs (map car (reverse! object-alist))))
+ (make-bytespec nargs nrest nlocs bytes objs))))))
+
+(define (map/index f l)
+ (do ((n 0 (1+ n))
+ (l l (cdr l))
+ (r '() (cons (f (car l) n) r)))
+ ((null? l) (reverse! r))))
+
+;; Optimization
+
+(define *optimize-table*
+ '((not (not . not-not)
+ (eq? . not-eq?)
+ (null? . not-null?)
+ (not-not . not)
+ (not-eq? . eq?)
+ (not-null? . null?))
+ (br-if (not . br-if-not)
+ (eq? . br-if-eq)
+ (null? . br-if-null)
+ (not-not . br-if)
+ (not-eq? . br-if-not-eq)
+ (not-null? . br-if-not-null))
+ (br-if-not (not . br-if)
+ (eq? . br-if-not-eq)
+ (null? . br-if-not-null)
+ (not-not . br-if-not)
+ (not-eq? . br-if-eq)
+ (not-null? . br-if-null))))
+
+(define (optimizing-push code stack)
+ (let ((alist (assq-ref *optimize-table* (car code))))
+ (cond ((and alist (pair? stack) (assq-ref alist (car stack))) =>
+ (lambda (inst) (append! (reverse! (cons inst (cdr code)))
+ (cdr stack))))
+ (else (append! (reverse! (code-finalize code)) stack)))))
+
+
+;;;
+;;; Stage3: Dumpcode generation
+;;;
+
+(define (dump bytespec)
+ (let* ((table (build-object-table bytespec))
+ (bytes (bytespec->bytecode bytespec table '(return))))
+ (if (null? table)
+ bytes
+ (let ((spec (make-bytespec 0 0 (length table) bytes '())))
+ (bytespec->bytecode spec '() '(tail-call 0))))))
+
+(define (bytespec->bytecode bytespec object-table last-code)
+ (let ((stack '()))
+ (define (push-code! x)
+ (set! stack (cons x stack)))
+ (define (object-index x)
+ (cond ((object-find object-table x) => cdr)
+ (else #f)))
+ (define (dump-table-object! obj+index)
+ (let dump! ((x (car obj+index)))
+ (cond
+ ((vlink? x)
+ (push-code! `(local-ref ,(object-index (vlink-module x))))
+ (push-code! `(load-symbol ,(vlink-name x)))
+ (push-code! `(link)))
+ ((vmod? x)
+ (push-code! `(load-module ,(vmod-id x))))
+ (else
+ (for-each push-code! (object->dump-code x)))))
+ (push-code! `(local-set ,(cdr obj+index))))
+ (define (dump-object! x)
+ (let dump! ((x x))
+ (cond
+ ((bytespec? x) (dump-bytecode! x))
+ ((object-index x) => (lambda (i) (push-code! `(local-ref ,i))))
+ (else
+ (error "Cannot dump:" x)))))
+ (define (dump-bytecode! spec)
+ (let ((nargs (bytespec-nargs spec))
+ (nrest (bytespec-nrest spec))
+ (nlocs (bytespec-nlocs spec))
+ (objs (bytespec-objs spec)))
+ (if (and (null? objs) (< nargs 4) (< nlocs 16))
+ ;; zero-object encoding
+ (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
+ (begin
+ ;; dump parameters
+ (push-code! (object->code nargs))
+ (push-code! (object->code nrest))
+ (push-code! (object->code nlocs))
+ ;; dump object table
+ (cond ((null? objs) (push-code! (object->code #f)))
+ (else
+ (push-code! `(mark))
+ (for-each dump-object! objs)
+ (push-code! `(vector))))))
+ ;; dump bytecode
+ (push-code! `(load-program ,(bytespec-bytes spec)))))
+ ;;
+ ;; main
+ (for-each dump-table-object! object-table)
+ (dump-bytecode! bytespec)
+ (push-code! last-code)
+ (code->bytes (apply append! (map code-finalize (reverse! stack))))))
+
+;; object table
+
+(define (object-find table x)
+ ((if (or (vlink? x) (vmod? x)) assoc assq) x table))
+
+(define (build-object-table bytespec)
+ (let ((table '()) (index 0))
+ (define (insert! x)
+ (if (vlink? x) (begin (insert! (vlink-module x))))
+ (if (not (object-find table x))
+ (begin
+ (set! table (acons x index table))
+ (set! index (1+ index)))))
+ (let loop ((spec bytespec))
+ (for-each (lambda (x)
+ (if (bytespec? x) (loop x) (insert! x)))
+ (bytespec-objs spec)))
+ (reverse! table)))
+
+;; code generation
+
+(define (code-finalize code)
+ (match code
+ ((inst (? symbol? s))
+ (let ((str (symbol->string s)))
+ `(,inst ,(string-length str) ,str)))
+ ((inst (? string? s))
+ `(,inst ,(string-length s) ,s))
+ (else (code-pack code))))
+
+(define (integer->string n) (make-string 1 (integer->char n)))
+
+(define (length->string len)
+ (define C integer->char)
+ (list->string
+ (cond ((< len 254) (list (C len)))
+ ((< len 65536)
+ (list (C 254) (C (quotient len 256)) (C (modulo len 256))))
+ ((< len most-positive-fixnum)
+ (list (C 255)
+ (C (quotient len (* 256 256 256)))
+ (C (modulo (quotient len (* 256 256)) 256))
+ (C (modulo (quotient len 256) 256))
+ (C (modulo len 256))))
+ (else (error "Too long" len)))))
+
+(define (code->bytes code)
+ (let* ((code (list->vector code))
+ (size (vector-length code)))
+ (let loop ((i 0))
+ (if (>= i size)
+ (apply string-append (vector->list code))
+ (let ((inst (vector-ref code i)))
+ (if (not (instruction? inst))
+ (error "Unknown instruction:" inst))
+ (vector-set! code i (integer->string (instruction->opcode inst)))
+ (let ((bytes (instruction-length inst)))
+ (cond ((< bytes 0)
+ (vector-set! code i
+ (integer->string (instruction->opcode inst)))
+ (vector-set! code (+ i 1)
+ (length->string (vector-ref code (1+ i))))
+ (loop (+ i 3)))
+ ((= bytes 0) (loop (+ i 1)))
+ (else
+ (let ((end (+ i 1 bytes)))
+ (do ((j (+ i 1) (1+ j)))
+ ((= j end) (loop end))
+ (vector-set! code j (integer->string
+ (vector-ref code j)))))))))))))
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
new file mode 100644
index 000000000..31993d2ac
--- /dev/null
+++ b/module/system/vm/conv.scm
@@ -0,0 +1,137 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm conv)
+ :use-module (system vm core)
+ :use-module (ice-9 match)
+ :use-module (ice-9 regex)
+ :export (code-pack code-unpack object->code object->dump-code code->object))
+
+(define (code-pack code)
+ (match code
+ ((inst (? integer? n))
+ (cond ((< n 10)
+ (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
+ (if (instruction? abbrev) (list abbrev) code)))
+ ((> n 255)
+ (let ((double (string->symbol (format #f "~A*2" inst))))
+ (if (instruction? double)
+ (list double (quotient n 256) (modulo n 256))
+ (apply error "Index out of range:" code))))
+ (else code)))
+ (else code)))
+
+(define (code-unpack code)
+ (let ((inst (symbol->string (car code))))
+ (cond
+ ((string-match "^([^:]*):([0-9]+)$" inst) =>
+ (lambda (data)
+ (cons* (string->symbol (match:substring data 1))
+ (string->number (match:substring data 2))
+ (cdr code))))
+ (else code))))
+
+(define (object->code x)
+ (cond ((eq? x #t) `(make-true))
+ ((eq? x #f) `(make-false))
+ ((null? x) `(make-eol))
+ ((integer? x)
+ (cond ((and (<= -128 x) (< x 128))
+ `(make-int8 ,(modulo x 256)))
+ ((and (<= -32768 x) (< x 32768))
+ (let ((n (if (< x 0) (+ x 65536) x)))
+ `(make-int16 ,(quotient n 256) ,(modulo n 256))))
+ (else #f)))
+ ((char? x) `(make-char8 ,(char->integer x)))
+ (else #f)))
+
+(define (object->dump-code x)
+ (let ((stack '()))
+ (define (push-code! code)
+ (set! stack (cons code stack)))
+ (let dump! ((x x))
+ (cond
+ ((object->code x) => push-code!)
+ ((string? x)
+ (push-code! `(load-string ,x)))
+ ((symbol? x)
+ (push-code! `(load-symbol ,(symbol->string x))))
+ ((keyword? x)
+ (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
+ ((list? x)
+ (push-code! `(mark))
+ (for-each dump! x)
+ (push-code! `(list)))
+ ((pair? x)
+ (dump! (car x))
+ (dump! (cdr x))
+ (push-code! `(cons)))
+ ((vector? x)
+ (push-code! `(mark))
+ (for-each dump! (vector->list x))
+ (push-code! `(vector)))
+ (else
+ (error "Cannot dump:" x))))
+ (reverse! stack)))
+
+(define (code->object code)
+ (match code
+ (('make-true) #t)
+ (('make-false) #f) ;; FIXME: Same as the `else' case!
+ (('make-eol) '())
+ (('make-int8 n)
+ (if (< n 128) n (- n 256)))
+ (('make-int16 n1 n2)
+ (let ((n (+ (* n1 256) n2)))
+ (if (< n 32768) n (- n 65536))))
+ (('make-char8 n)
+ (integer->char n))
+ (else #f)))
+
+(define-public (make-byte-decoder bytes)
+ (let ((addr 0) (size (string-length bytes)))
+ (define (pop)
+ (let ((byte (char->integer (string-ref bytes addr))))
+ (set! addr (1+ addr))
+ byte))
+ (define (pop-length)
+ (let ((len (pop)))
+ (cond ((< len 254) len)
+ ((= len 254) (+ (* (pop) 256) (pop)))
+ (else (+ (* (pop) 256 256 256) (* (pop) 256 256)
+ (* (pop) 256) (pop))))))
+ (lambda ()
+ (if (< addr size)
+ (let* ((start addr)
+ (inst (opcode->instruction (pop)))
+ (n (instruction-length inst))
+ (code (if (< n 0)
+ ;; variable length
+ (let* ((end (+ (pop-length) addr))
+ (str (substring bytes addr end)))
+ (set! addr end)
+ (list inst str))
+ ;; fixed length
+ (do ((n n (1- n))
+ (l '() (cons (pop) l)))
+ ((= n 0) (cons* inst (reverse! l)))))))
+ (values start code))
+ #f))))
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
new file mode 100644
index 000000000..808cc9ec7
--- /dev/null
+++ b/module/system/vm/core.scm
@@ -0,0 +1,35 @@
+;;; Guile VM core
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm core))
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguilevm.so"))
+
+(export vms:cons vms:time vms:clock)
+
+(define (vms:cons stat) (vector-ref stat 0))
+(define (vms:time stat) (vector-ref stat 1))
+(define (vms:clock stat) (vector-ref stat 2))
+
+(module-export! (current-module)
+ (delq! '%module-public-interface
+ (hash-fold (lambda (k v d) (cons k d)) '()
+ (module-obarray (current-module)))))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
new file mode 100644
index 000000000..7ec24ed12
--- /dev/null
+++ b/module/system/vm/disasm.scm
@@ -0,0 +1,118 @@
+;;; Guile VM Disassembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm disasm)
+ :use-module (system vm core)
+ :use-module (system vm conv)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 match)
+ :use-module (ice-9 format)
+ :use-module (ice-9 receive)
+ :use-module (ice-9 and-let-star)
+ :export (disassemble-program disassemble-bytecode))
+
+(define (disassemble-program prog . opts)
+ (let* ((arity (program-arity prog))
+ (nargs (car arity))
+ (nrest (cadr arity))
+ (nlocs (caddr arity))
+ (bytes (program-bytecode prog))
+ (objs (program-objects prog)))
+ ;; Disassemble this bytecode
+ (format #t "Disassembly of ~A:\n\n" prog)
+ (format #t "args = ~A rest = ~A locals = ~A\n\n" nargs nrest nlocs)
+ (format #t "Bytecode:\n\n")
+ (disassemble-bytecode bytes objs)
+ (if (> (vector-length objs) 0)
+ (disassemble-objects objs))
+ ;; Disassemble other bytecode in it
+ (for-each
+ (lambda (x)
+ (if (program? x)
+ (begin (display "----------------------------------------\n")
+ (apply disassemble-program x opts))))
+ (vector->list objs))))
+
+(define (disassemble-bytecode bytes . opt)
+ (let ((decode (make-byte-decoder bytes))
+ (rest '()))
+ (do ((addr+code (decode) (decode)))
+ ((not addr+code) (newline))
+ (receive (addr code) addr+code
+ (match code
+ (('load-program x)
+ (let ((sym (gensym "")))
+ (set! rest (acons sym x rest))
+ (print-info addr (format #f "load-program #~A" sym) #f)))
+ (else
+ (let ((info (list->string code))
+ (extra (original-value code (if (null? opt) #f (car opt)))))
+ (print-info addr info extra))))))
+ (for-each (lambda (sym+bytes)
+ (format #t "Bytecode #~A:\n\n" (car sym+bytes))
+ (disassemble-bytecode (cdr sym+bytes)))
+ (reverse! rest))))
+
+(define (disassemble-objects objs)
+ (display "Objects:\n\n")
+ (let ((len (vector-length objs)))
+ (do ((n 0 (1+ n)))
+ ((= n len) (newline))
+ (let ((info (object->string (vector-ref objs n))))
+ (print-info n info #f)))))
+
+(define (disassemble-meta meta)
+ (display "Meta info:\n\n")
+ (for-each (lambda (data)
+ (print-info (car data) (list->string (cdr data)) #f))
+ meta)
+ (newline))
+
+(define (original-value code table)
+ (define (branch-code? code)
+ (string-match "^(br|jump)" (symbol->string (car code))))
+ (let ((code (code-unpack code)))
+ (cond ((code->object code) => object->string)
+;;; ((branch-code? code)
+;;; (format #f "-> ~A" (+ addr (cadr code))))
+ (else
+ (let ((inst (car code)) (args (cdr code)))
+ (case inst
+ ((make-false) "#f")
+;;; ((object-ref)
+;;; (object->string (vector-ref objs (car args))))
+ ((local-ref local-set)
+ ;;'(ref x))
+ #f)
+;;; ((module-ref module-set)
+;;; (let ((var (vector-ref objs (car args))))
+;;; (list (if (eq? inst 'module-ref) 'ref 'set)
+;;; (if (pair? var) (car var) var))))
+ (else #f)))))))
+
+(define (list->string list)
+ (let ((str (object->string list)))
+ (substring str 1 (1- (string-length str)))))
+
+(define (print-info addr info extra)
+ (if extra
+ (format #t "~4@A ~24A;; ~A\n" addr info extra)
+ (format #t "~4@A ~A\n" addr info)))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
new file mode 100644
index 000000000..5c043f2b1
--- /dev/null
+++ b/module/system/vm/frame.scm
@@ -0,0 +1,32 @@
+;;; Guile VM frame utilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm frame)
+ :use-module (system vm core)
+ :export (frame->call))
+
+(define (frame->call frame)
+ (let ((prog (frame-program frame)))
+ (cons prog (reverse! (vector->list (frame-variables frame))))))
+
+; (define-method (binding (prog <program>))
+; (fold (lambda (s v d) (if (eq? v prog) s d))
+; #f (program-environment prog)))
diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm
new file mode 100644
index 000000000..c92e6c441
--- /dev/null
+++ b/module/system/vm/profile.scm
@@ -0,0 +1,66 @@
+;;; Guile VM profiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm profile)
+ :use-module (system vm core)
+ :use-module (ice-9 format)
+ :export (vm-profile))
+
+(define (vm-profile vm prog . opts)
+ (let ((flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-option! vm 'debug #t)
+ (set-vm-option! vm 'profile-data '())
+ (add-hook! (vm-next-hook vm) profile-next)
+ (add-hook! (vm-enter-hook vm) profile-enter)
+ (add-hook! (vm-exit-hook vm) profile-exit))
+ (lambda ()
+ (let ((val (vm prog)))
+ (display-result vm)
+ val))
+ (lambda ()
+ (set-vm-option! vm 'debug flag)
+ (remove-hook! (vm-next-hook vm) profile-next)
+ (remove-hook! (vm-enter-hook vm) profile-enter)
+ (remove-hook! (vm-exit-hook vm) profile-exit)))))
+
+(define (profile-next vm)
+ (set-vm-option! vm 'profile-data
+ (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
+
+(define (profile-enter vm)
+ #f)
+
+(define (profile-exit vm)
+ #f)
+
+(define (display-result vm . opts)
+ (do ((data (vm-option vm 'profile-data) (cdr data))
+ (summary '() (let ((inst (caar data)))
+ (assq-set! summary inst
+ (1+ (or (assq-ref summary inst) 0))))))
+ ((null? data)
+ (display "Count Instruction\n")
+ (display "----- -----------\n")
+ (for-each (lambda (entry)
+ (format #t "~5@A ~A\n" (cdr entry) (car entry)))
+ (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
new file mode 100644
index 000000000..88933003d
--- /dev/null
+++ b/module/system/vm/trace.scm
@@ -0,0 +1,75 @@
+;;; Guile VM tracer
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm trace)
+ :use-module (oop goops)
+ :use-syntax (system base syntax)
+ :use-module (system base module)
+ :use-module (system vm core)
+ :use-module (system vm frame)
+ :use-module (ice-9 format)
+ :export (vm-trace))
+
+(define (vm-trace vm prog . opts)
+ (let ((flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-option! vm 'debug #t)
+ (set-vm-option! vm 'first-apply #t)
+ (if (memq :a opts)
+ (add-hook! (vm-next-hook vm) trace-next))
+ (add-hook! (vm-apply-hook vm) trace-apply)
+ (add-hook! (vm-return-hook vm) trace-return))
+ (lambda ()
+ (vm prog))
+ (lambda ()
+ (set-vm-option! vm 'debug flag)
+ (if (memq :a opts)
+ (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-apply-hook vm) trace-apply)
+ (remove-hook! (vm-return-hook vm) trace-return)))))
+
+(define (trace-next vm)
+ (let ((frame (vm-current-frame vm)))
+ (format #t "0x~X ~20S~S\t~S\n"
+ (vm:ip vm)
+ (vm-fetch-code vm)
+ (frame-variables frame)
+ (vm-fetch-stack vm))))
+
+(define (trace-apply vm)
+ (if (vm-option vm 'first-apply)
+ (set-vm-option! vm 'first-apply #f) ;; skip the initial program
+ (let ((frame (vm-current-frame vm)))
+ (print-prefix (frame-dynamic-link frame))
+ (write (frame->call frame))
+ (newline))))
+
+(define (trace-return vm)
+ (let ((frame (vm-current-frame vm)))
+ (print-prefix (frame-dynamic-link frame))
+ (write (car (vm-fetch-stack vm)))
+ (newline)))
+
+(define (print-prefix frame)
+ (and-let* ((link (frame-dynamic-link frame)))
+ (display "| ")
+ (print-prefix link)))
diff --git a/src/.cvsignore b/src/.cvsignore
index 0ca232e65..9403d5368 100644
--- a/src/.cvsignore
+++ b/src/.cvsignore
@@ -1,8 +1,6 @@
-.cvsignore
.libs
.deps
guile-vm
-guile-compile
stamp-h
config.h
config.h.in
@@ -10,8 +8,6 @@ stamp-h.in
Makefile
Makefile.in
*.x
-*.inst
-*.label
-*.opcode
+*.i
*.lo
*.la
diff --git a/src/Makefile.am b/src/Makefile.am
index 56b724975..621c450ab 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -3,39 +3,27 @@ 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_SOURCES = envs.c instructions.c programs.c vm.c \
+ envs.h instructions.h programs.h vm.h vm_engine.h vm_expand.h
libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
-noinst_HEADERS = vm.h vm_engine.h vm_expand.h
-EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \
- test.scm guile-compile.in
-BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm.x
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c vm_loader.c
+BUILT_SOURCES = vm_system.i vm_scheme.i vm_number.i vm_loader.i \
+ envs.x instructions.x programs.x vm.x
-CFLAGS = -g -O2 -Wall
INCLUDES = $(GUILE_CFLAGS)
-CLEANFILES = $(bin_SCRIPTS)
DISTCLEANFILES = $(BUILT_SOURCES)
MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in
+ETAGS_ARGS = --regex='/SCM_\(SYMBOL\|VCELL\).*\"\([^\"]\)*\"/\3/' \
+ --regex='/SCM_DEFINE[ \t]*(\([^,]*\),[^,]*/\1/'
+
SNARF = guile-snarf
-SUFFIXES = .x .i
+SUFFIXES = .i .x
+.c.i:
+ grep '^VM_DEFINE' $< > $@
.c.x:
- $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+ $(SNARF) $< $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
|| { rm $@; false; }
-.c.i:
- grep '^SCM_DEFINE' $< > $@
-
$(BUILT_SOURCES): config.h vm_expand.h
-
-guile-compile: guile-compile.in
- sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \
- $< > $@
-
-test: all
- $(bin_PROGRAMS) -s test.scm
-
-debug-test: all
- $(bin_PROGRAMS) -s test.scm debug
diff --git a/src/envs.c b/src/envs.c
new file mode 100644
index 000000000..a6c12bdea
--- /dev/null
+++ b/src/envs.c
@@ -0,0 +1,250 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#include <string.h>
+#include "envs.h"
+
+#define ENV_OBARRAY_SIZE 31
+
+
+scm_bits_t scm_tc16_env;
+
+SCM
+scm_c_make_env (void)
+{
+ struct scm_env *p = scm_must_malloc (sizeof (struct scm_env),
+ "scm_c_make_env");
+ p->identifier = SCM_BOOL_F;
+ p->obarray = scm_c_make_hash_table (ENV_OBARRAY_SIZE);
+ SCM_RETURN_NEWSMOB (scm_tc16_env, p);
+}
+
+static SCM
+env_mark (SCM obj)
+{
+ struct scm_env *p = SCM_ENV_DATA (obj);
+ scm_gc_mark (p->identifier);
+ return p->obarray;
+}
+
+static scm_sizet
+env_free (SCM obj)
+{
+ scm_must_free (SCM_ENV_DATA (obj));
+ return sizeof (struct scm_env);
+}
+
+
+/*
+ * C interface
+ */
+
+static SCM env_table;
+static SCM load_env;
+
+SCM
+scm_c_lookup_env (SCM identifier)
+{
+ /* Check if the env is already loaded */
+ SCM vcell = scm_sym2ovcell_soft (identifier, env_table);
+
+ /* If not, load the env */
+ if (SCM_FALSEP (vcell))
+ {
+ SCM env = scm_apply (SCM_CDR (load_env),
+ SCM_LIST1 (identifier), SCM_EOL);
+ if (!SCM_ENV_P (env))
+ scm_misc_error ("scm_c_lookup_env",
+ "Invalid env: ~S", SCM_LIST1 (env));
+ scm_intern_symbol (env_table, identifier);
+ vcell = scm_sym2ovcell_soft (identifier, env_table);
+ SCM_SETCDR (vcell, env);
+ }
+
+ return SCM_CDR (vcell);
+}
+
+SCM
+scm_c_env_vcell (SCM env, SCM name, int intern)
+{
+ SCM ob = SCM_ENV_OBARRAY (env);
+ if (intern)
+ scm_intern_symbol (ob, name);
+ return scm_sym2ovcell_soft (name, ob);
+}
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_make_env, "make-env", 0, 0, 0,
+ (),
+ "")
+#define FUNC_NAME s_scm_make_env
+{
+ return scm_c_make_env ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_p, "env?", 1, 0, 0,
+ (SCM x),
+ "")
+#define FUNC_NAME s_scm_env_p
+{
+ return SCM_BOOL (SCM_ENV_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_identifier, "env-identifier", 1, 0, 0,
+ (SCM env),
+ "")
+#define FUNC_NAME s_scm_env_identifier
+{
+ SCM_VALIDATE_ENV (1, env);
+ return SCM_ENV_IDENTIFIER (env);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_env_identifier_x, "set-env-identifier!", 2, 0, 0,
+ (SCM env, SCM identifier),
+ "")
+#define FUNC_NAME s_scm_set_env_identifier_x
+{
+ SCM_VALIDATE_ENV (1, env);
+ SCM_VALIDATE_SYMBOL (2, identifier);
+ SCM_ENV_IDENTIFIER (env) = identifier;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0,
+ (SCM env, SCM name),
+ "")
+#define FUNC_NAME s_scm_env_bound_p
+{
+ SCM vcell;
+ SCM_VALIDATE_ENV (1, env);
+ SCM_VALIDATE_SYMBOL (2, name);
+ vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+ return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0,
+ (SCM env, SCM name),
+ "")
+#define FUNC_NAME s_scm_env_ref
+{
+ SCM vcell;
+ SCM_VALIDATE_ENV (1, env);
+ SCM_VALIDATE_SYMBOL (2, name);
+ vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+ if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)))
+ SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
+ SCM_LIST2 (env, name));
+ return SCM_CDR (vcell);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0,
+ (SCM env, SCM name, SCM val),
+ "")
+#define FUNC_NAME s_scm_env_set_x
+{
+ SCM vcell;
+ SCM_VALIDATE_ENV (1, env);
+ SCM_VALIDATE_SYMBOL (2, name);
+ vcell = scm_sym2ovcell_soft (name, SCM_ENV_OBARRAY (env));
+ if (SCM_FALSEP (vcell))
+ SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
+ SCM_LIST2 (env, name));
+ SCM_SETCDR (vcell, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_define, "env-define", 3, 0, 0,
+ (SCM env, SCM name, SCM val),
+ "")
+#define FUNC_NAME s_scm_env_define
+{
+ SCM vcell;
+ SCM_VALIDATE_ENV (1, env);
+ SCM_VALIDATE_SYMBOL (2, name);
+ vcell = scm_c_env_vcell (env, name, 1);
+ SCM_SETCDR (vcell, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_envs (void)
+{
+ SCM mod, old;
+
+ scm_tc16_env = scm_make_smob_type ("env", 0);
+ scm_set_smob_mark (scm_tc16_env, env_mark);
+ scm_set_smob_free (scm_tc16_env, env_free);
+
+ env_table = scm_permanent_object (scm_c_make_hash_table (51));
+
+ mod = scm_resolve_module (scm_read_0str ("(system base module)"));
+ old = scm_set_current_module (mod);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "envs.x"
+#endif
+
+ load_env = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
+ scm_str2symbol ("load-env"),
+ SCM_BOOL_T);
+ load_env = SCM_VARVCELL (load_env);
+
+ scm_set_current_module (old);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/envs.h b/src/envs.h
new file mode 100644
index 000000000..ddc5ea498
--- /dev/null
+++ b/src/envs.h
@@ -0,0 +1,73 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice. */
+
+#ifndef _ENVS_H_
+#define _ENVS_H_
+
+#include <libguile.h>
+#include "config.h"
+
+extern scm_bits_t scm_tc16_env;
+
+struct scm_env {
+ SCM identifier;
+ SCM obarray;
+};
+
+#define SCM_ENV_P(x) SCM_SMOB_PREDICATE (scm_tc16_env, x)
+#define SCM_ENV_DATA(x) ((struct scm_env *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_ENV(p,x) SCM_MAKE_VALIDATE (p, x, ENV_P)
+
+#define SCM_ENV_IDENTIFIER(x) (SCM_ENV_DATA(x)->identifier)
+#define SCM_ENV_OBARRAY(x) (SCM_ENV_DATA(x)->obarray)
+
+extern SCM scm_c_lookup_env (SCM identifier);
+extern SCM scm_c_env_vcell (SCM env, SCM name, int intern);
+
+extern void scm_init_envs (void);
+
+#endif /* _ENVS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/guile-compile.in b/src/guile-compile.in
deleted file mode 100644
index 1589d220e..000000000
--- a/src/guile-compile.in
+++ /dev/null
@@ -1,6 +0,0 @@
-#!@bindir@/@PACKAGE@ -s
-!#
-
-(use-modules (vm compile))
-
-(for-each compile-file (cdr (command-line)))
diff --git a/src/guile-vm.c b/src/guile-vm.c
index 5d3c1c1a6..581c30a88 100644
--- a/src/guile-vm.c
+++ b/src/guile-vm.c
@@ -41,18 +41,10 @@
#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);
+ scm_init_guile ();
+ scm_shell (argc, argv);
return 0; /* never reached */
}
diff --git a/src/instructions.c b/src/instructions.c
new file mode 100644
index 000000000..fc5147b74
--- /dev/null
+++ b/src/instructions.c
@@ -0,0 +1,138 @@
+/* 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 <string.h>
+#include "instructions.h"
+
+struct scm_instruction scm_instruction_table[] = {
+#define VM_INSTRUCTION_TO_TABLE 1
+#include "vm_expand.h"
+#include "vm_system.i"
+#include "vm_scheme.i"
+#include "vm_number.i"
+#include "vm_loader.i"
+#undef VM_INSTRUCTION_TO_TABLE
+ {scm_op_last}
+};
+
+/* C interface */
+
+struct scm_instruction *
+scm_lookup_instruction (SCM name)
+{
+ struct scm_instruction *ip;
+ if (SCM_SYMBOLP (name))
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ if (strcmp (ip->name, SCM_SYMBOL_CHARS (name)) == 0)
+ return ip;
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_instruction_list
+{
+ SCM list = SCM_EOL;
+ struct scm_instruction *ip;
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ list = scm_cons (scm_str2symbol (ip->name), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_instruction_p
+{
+ return SCM_BOOL (SCM_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_length
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_MAKINUM (SCM_INSTRUCTION_LEN (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
+ (SCM op),
+ "")
+#define FUNC_NAME s_scm_opcode_to_instruction
+{
+ int i;
+ SCM_VALIDATE_INUM (1, op);
+ i = SCM_INUM (op);
+ SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
+ return scm_str2symbol (scm_instruction_table[i].name);
+}
+#undef FUNC_NAME
+
+void
+scm_init_instructions (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "instructions.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/instructions.h b/src/instructions.h
new file mode 100644
index 000000000..425d1a34e
--- /dev/null
+++ b/src/instructions.h
@@ -0,0 +1,84 @@
+/* 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 _INSTRUCTIONS_H_
+#define _INSTRUCTIONS_H_
+
+#include <libguile.h>
+#include "config.h"
+
+enum scm_opcode {
+#define VM_INSTRUCTION_TO_OPCODE 1
+#include "vm_expand.h"
+#include "vm_system.i"
+#include "vm_scheme.i"
+#include "vm_number.i"
+#include "vm_loader.i"
+#undef VM_INSTRUCTION_TO_OPCODE
+ scm_op_last
+};
+
+struct scm_instruction {
+ enum scm_opcode opcode; /* opcode */
+ char *name; /* instruction name */
+ char len; /* byte length */
+};
+
+#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x))
+#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode)
+#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name)
+#define SCM_INSTRUCTION_LEN(i) (scm_lookup_instruction (i)->len)
+#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
+
+#define SCM_INSTRUCTION(i) (&scm_instruction_table[i])
+
+extern struct scm_instruction scm_instruction_table[];
+extern struct scm_instruction *scm_lookup_instruction (SCM name);
+
+extern void scm_init_instructions (void);
+
+#endif /* _INSTRUCTIONS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/programs.c b/src/programs.c
new file mode 100644
index 000000000..93ba54ab8
--- /dev/null
+++ b/src/programs.c
@@ -0,0 +1,209 @@
+/* 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 <string.h>
+#include "instructions.h"
+#include "programs.h"
+#include "vm.h"
+
+
+scm_bits_t scm_tc16_program;
+
+static SCM zero_vector;
+
+SCM
+scm_c_make_program (void *addr, size_t size, SCM holder)
+#define FUNC_NAME "scm_c_make_program"
+{
+ struct scm_program *p = SCM_MUST_MALLOC (sizeof (struct scm_program));
+ p->size = size;
+ p->nargs = 0;
+ p->nrest = 0;
+ p->nlocs = 0;
+ p->meta = SCM_EOL;
+ p->objs = zero_vector;
+ p->external = SCM_EOL;
+ p->holder = holder;
+
+ /* If nobody holds bytecode's address, then allocate a new memory */
+ if (SCM_FALSEP (p->holder))
+ p->base = SCM_MUST_MALLOC (size);
+ else
+ p->base = addr;
+
+ SCM_RETURN_NEWSMOB (scm_tc16_program, p);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_vclosure (SCM program, SCM external)
+{
+ struct scm_program *p;
+ struct scm_program *q = SCM_PROGRAM_DATA (program);
+ SCM prog = scm_c_make_program (q->base, q->size, program);
+ p = SCM_PROGRAM_DATA (prog);
+ p->nargs = q->nargs;
+ p->nrest = q->nrest;
+ p->nlocs = q->nlocs;
+ p->meta = q->meta;
+ p->objs = q->objs;
+ p->external = external;
+ return prog;
+}
+
+static SCM
+program_mark (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_gc_mark (p->meta);
+ scm_gc_mark (p->objs);
+ scm_gc_mark (p->external);
+ return p->holder;
+}
+
+static scm_sizet
+program_free (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_sizet size = (sizeof (struct scm_program));
+ if (SCM_FALSEP (p->holder))
+ {
+ size += p->size;
+ scm_must_free (p->base);
+ }
+ scm_must_free (p);
+ return size;
+}
+
+static int
+program_print (SCM obj, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<program 0x", port);
+ scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+ return scm_vm_apply (scm_make_vm (), program, args);
+}
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_program_p
+{
+ return SCM_BOOL (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arity
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_LIST3 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)),
+ SCM_MAKINUM (SCM_PROGRAM_NREST (program)),
+ SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_objects
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_OBJS (program);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_external
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_EXTERNAL (program);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_bytecode
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_makfromstr (SCM_PROGRAM_BASE (program),
+ SCM_PROGRAM_SIZE (program), 0);
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_programs (void)
+{
+ zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
+
+ scm_tc16_program = scm_make_smob_type ("program", 0);
+ scm_set_smob_mark (scm_tc16_program, program_mark);
+ scm_set_smob_free (scm_tc16_program, program_free);
+ scm_set_smob_print (scm_tc16_program, program_print);
+ scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "programs.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/programs.h b/src/programs.h
new file mode 100644
index 000000000..e1b2b3e9b
--- /dev/null
+++ b/src/programs.h
@@ -0,0 +1,94 @@
+/* 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 _PROGRAM_H_
+#define _PROGRAM_H_
+
+#include <libguile.h>
+#include "config.h"
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+struct scm_program {
+ size_t size; /* the size of the program */
+ unsigned char nargs; /* the number of arguments */
+ unsigned char nrest; /* have a rest argument or not */
+ unsigned short nlocs; /* the number of local variables */
+ scm_byte_t *base; /* program base address */
+ SCM meta; /* meta information */
+ SCM objs; /* constant objects */
+ SCM external; /* external environment */
+ SCM holder; /* the owner of bytecode */
+};
+
+extern scm_bits_t scm_tc16_program;
+
+#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
+#define SCM_PROGRAM_SIZE(x) (SCM_PROGRAM_DATA (x)->size)
+#define SCM_PROGRAM_NARGS(x) (SCM_PROGRAM_DATA (x)->nargs)
+#define SCM_PROGRAM_NREST(x) (SCM_PROGRAM_DATA (x)->nrest)
+#define SCM_PROGRAM_NLOCS(x) (SCM_PROGRAM_DATA (x)->nlocs)
+#define SCM_PROGRAM_BASE(x) (SCM_PROGRAM_DATA (x)->base)
+#define SCM_PROGRAM_META(x) (SCM_PROGRAM_DATA (x)->meta)
+#define SCM_PROGRAM_OBJS(x) (SCM_PROGRAM_DATA (x)->objs)
+#define SCM_PROGRAM_LINKS(x) (SCM_PROGRAM_DATA (x)->links)
+#define SCM_PROGRAM_EXTERNAL(x) (SCM_PROGRAM_DATA (x)->external)
+#define SCM_PROGRAM_HOLDER(x) (SCM_PROGRAM_DATA (x)->holder)
+
+extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
+extern SCM scm_c_make_vclosure (SCM program, SCM external);
+
+extern void scm_init_programs (void);
+
+#endif /* _PROGRAM_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/test.scm b/src/test.scm
deleted file mode 100644
index 85d747fea..000000000
--- a/src/test.scm
+++ /dev/null
@@ -1,60 +0,0 @@
-
-(set! %load-path (cons ".." %load-path))
-(use-modules (vm vm))
-(use-modules (vm shell))
-(use-modules (vm compile))
-(use-modules (ice-9 syncase))
-
-(define *verbose-output* (if (null? (cdr (command-line))) #f #t))
-
-(define test-list
- '((1 1)
- ((1- 1) 0)
- ((+ (+ 1) (- 2)) -1)
- ((+ (+ 1 2) (- 1 2) (* 1 2) (/ 1 2)) 4.5)
- ((* (- 1 2 3) (+ 1.2 3.4) (/ 1 2 4)) -2.3)
- ((let ((a 1)) a) 1)
- ((let ((a 1) (b 2)) b) 2)
- ((let* ((a 1) (a 2)) a) 2)
- ((let ((a 1)) (let ((b 2)) a)) 1)
- ((let ((a 1) (b 2) (c 3))
- ((lambda (d e f)
- ((lambda (g h i)
- ((lambda () (list a b d f h i))))
- 7 8 9))
- 4 5 6))
- (1 2 4 6 8 9))
- ((do ((i 3 (1- i)) (n 0 (+ n i))) ((< i 0) n)) 6)
- ((let () (define (foo a) a) (foo 1)) 1)
- ((begin (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
- (fib 3)) 2)
- ((begin (define (loop i l) (if (< i l) (loop (+ 1 i) l) l))
- (loop 0 3)) 3)
-; ((call-with-current-continuation (lambda (c) (c 1) 2)) 1)
- ((map 1+ '(1 2 3)) (2 3 4))
- ))
-
-(define (test vm form answer)
- (format #t "Testing ~S = ~S ..." form answer)
- (let ((result (vm-run vm (compile form))))
- (if (equal? result answer)
- (display "OK\n")
- (format #t "failed: ~S\n" result))))
-
-(define (debug-test vm form answer)
- (format #t "Testing ~S = ~S ...\n" form answer)
- (let ((result (begin
- (vm-set-option! vm 'verbose *verbose-output*)
- (vm-trace vm form))))
- (if (equal? result answer)
- (display "OK\n")
- (format #t "failed: ~S\n" result))))
-
-(let ((vm (make-vm)))
- (display "=== Testing the debug engine ===\n")
- (vm-set-option! vm 'debug #t)
- (for-each (lambda (q) (apply debug-test vm q)) test-list)
- (display "\n=== Testing the fast engine ===\n")
- (vm-set-option! vm 'debug #f)
- (for-each (lambda (q) (apply test vm q)) test-list)
- (display "done\n"))
diff --git a/src/vm.c b/src/vm.c
index a784fae0c..e82c1cb7f 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -39,14 +39,12 @@
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
-#define SCM_DEBUG_TYPING_STRICTNESS 0
-#include "config.h"
+#include <string.h>
+#include "instructions.h"
+#include "programs.h"
+#include "envs.h"
#include "vm.h"
-/* default stack size in the number of SCM */
-#define VM_DEFAULT_STACK_SIZE (16 * 1024) /* = 64KB */
-#define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */
-
/* I sometimes use this for debugging. */
#define vm_puts(OBJ) \
{ \
@@ -56,722 +54,79 @@
/*
- * Generic object name
- */
-
-static SCM scm_name_property;
-
-SCM_DEFINE (scm_name, "name", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_name
-{
- return scm_primitive_property_ref (scm_name_property, obj);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_set_name_x, "set-name!", 2, 0, 0,
- (SCM obj, SCM name),
-"")
-#define FUNC_NAME s_scm_set_name_x
-{
- SCM_VALIDATE_SYMBOL (2, name);
- return scm_primitive_property_set_x (scm_name_property, obj, name);
-}
-#undef FUNC_NAME
-
-int
-scm_smob_print_with_name (SCM smob, SCM port, scm_print_state *pstate)
-{
- int n = SCM_SMOBNUM (smob);
- SCM name = scm_name (smob);
- scm_puts ("#<", port);
- scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
- scm_putc (' ', port);
- if (SCM_FALSEP (name))
- {
- scm_puts ("0x", port);
- scm_intprint (SCM_UNPACK (scm_smobs[n].size ? SCM_CDR (smob) : smob),
- 16, port);
- }
- else
- {
- scm_display (name, port);
- }
- scm_putc ('>', port);
- return 1;
-}
-
-static void
-init_name_property ()
-{
- scm_name_property
- = scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F));
-}
-
-
-/*
- * Instruction
+ * VM Debug frame
*/
-static long scm_instruction_tag;
-
-static struct scm_instruction scm_instruction_table[] = {
-#define VM_INSTRUCTION_TO_TABLE
-#include "vm_expand.h"
-#include "vm_system.i"
-#include "vm_scheme.i"
-#include "vm_number.i"
-#undef VM_INSTRUCTION_TO_TABLE
- {op_last}
-};
-
-#define SCM_INSTRUCTION(OP) &scm_instruction_table[SCM_UNPACK (OP)]
+scm_bits_t scm_tc16_vm_debug_frame;
static SCM
-make_instruction (struct scm_instruction *instp)
-{
- SCM_RETURN_NEWSMOB (scm_instruction_tag, instp);
-}
-
-static int
-print_instruction (SCM obj, SCM port, scm_print_state *pstate)
-{
- scm_puts ("#<instruction ", port);
- scm_puts (SCM_INSTRUCTION_DATA (obj)->name, port);
- scm_putc ('>', port);
- return 1;
-}
-
-static void
-init_instruction_type ()
-{
- scm_instruction_tag = scm_make_smob_type ("instruction", 0);
- scm_set_smob_print (scm_instruction_tag, print_instruction);
-}
-
-/* C interface */
-
-static struct scm_instruction *
-scm_lookup_instruction (const char *name)
-{
- struct scm_instruction *p;
- for (p = scm_instruction_table; p->opcode != op_last; p++)
- if (strcmp (name, p->name) == 0)
- return p;
- return 0;
-}
-
-/* Scheme interface */
-
-SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_instruction_p
-{
- return SCM_BOOL (SCM_INSTRUCTION_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_system_instruction_p, "system-instruction?", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_system_instruction_p
-{
- return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_functional_instruction_p
-{
- return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0,
- (SCM name),
-"")
-#define FUNC_NAME s_scm_instruction_name_p
-{
- SCM_VALIDATE_SYMBOL (1, name);
- return SCM_BOOL (scm_lookup_instruction (SCM_SYMBOL_CHARS (name)));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0,
- (SCM name),
-"")
-#define FUNC_NAME s_scm_symbol_to_instruction
-{
- struct scm_instruction *p;
- SCM_VALIDATE_SYMBOL (1, name);
-
- p = scm_lookup_instruction (SCM_SYMBOL_CHARS (name));
- if (!p)
- SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name));
-
- return p->obj;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
- (),
-"")
-#define FUNC_NAME s_scm_instruction_list
-{
- SCM list = SCM_EOL;
- struct scm_instruction *p;
- for (p = scm_instruction_table; p->opcode != op_last; p++)
- list = scm_cons (p->obj, list);
- return scm_reverse_x (list, SCM_EOL);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0,
- (SCM inst),
-"")
-#define FUNC_NAME s_scm_instruction_opcode
+make_vm_debug_frame (SCM *fp)
{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode);
-}
-#undef FUNC_NAME
+ int i, size;
+ struct scm_vm_debug_frame *p;
-SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0,
- (SCM inst),
-"")
-#define FUNC_NAME s_scm_instruction_name
-{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0,
- (SCM inst),
-"")
-#define FUNC_NAME s_scm_instruction_type
-{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0,
- (SCM inst),
-"")
-#define FUNC_NAME s_scm_instruction_scheme_name
-{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
- return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname));
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0,
- (SCM inst),
-"")
-#define FUNC_NAME s_scm_instruction_arity
-{
- SCM_VALIDATE_INSTRUCTION (1, inst);
- if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
- {
- struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst);
- return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp));
- }
- else
+ if (!fp)
return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-
-/*
- * Bytecode
- */
-
-static long scm_bytecode_tag;
-
-static SCM
-make_bytecode (int size)
-{
- struct scm_bytecode *p
- = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode");
- p->size = size;
- SCM_RETURN_NEWSMOB (scm_bytecode_tag, p);
-}
-
-static SCM
-mark_bytecode (SCM bytecode)
-{
- int i;
- struct scm_instruction *p;
-
- int size = SCM_BYTECODE_SIZE (bytecode);
- SCM *base = SCM_BYTECODE_BASE (bytecode);
-
- for (i = 0; i < size; i++)
- {
- p = SCM_INSTRUCTION (base[i]);
- switch (p->type)
- {
- case INST_NONE:
- break;
- case INST_SCM:
- case INST_TOP:
- case INST_EXT:
- case INST_CODE:
- scm_gc_mark (base[++i]);
- break;
- case INST_INUM: /* a fixed integer; we don't need to mark it */
- case INST_ADDR: /* real memory address; we shouldn't mark it! */
- i++;
- }
- }
- return SCM_BOOL_F;
-}
-
-static int
-print_bytecode (SCM obj, SCM port, scm_print_state *pstate)
-{
- scm_puts ("#<bytecode 0x", port);
- scm_intprint ((long) SCM_BYTECODE_BASE (obj), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-static scm_sizet
-free_bytecode (SCM bytecode)
-{
- int size = (sizeof (struct scm_bytecode)
- + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM)));
- if (SCM_BYTECODE_EXTS (bytecode))
- {
- size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int);
- scm_must_free (SCM_BYTECODE_EXTS (bytecode));
- }
- scm_must_free (SCM_BYTECODE_DATA (bytecode));
- return size;
-}
-
-static void
-init_bytecode_type ()
-{
- scm_bytecode_tag = scm_make_smob_type ("bytecode", 0);
- scm_set_smob_mark (scm_bytecode_tag, mark_bytecode);
- scm_set_smob_print (scm_bytecode_tag, print_bytecode);
- scm_set_smob_free (scm_bytecode_tag, free_bytecode);
-}
-
-/* Internal functions */
-
-static SCM
-lookup_variable (SCM sym)
-{
- SCM eclo = scm_standard_eval_closure (scm_selected_module ());
- SCM var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_F);
- if (SCM_FALSEP (var))
- var = scm_eval_closure_lookup (eclo, sym, SCM_BOOL_T);
- return var;
-}
-
-/* Scheme interface */
-
-SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_bytecode_p
-{
- return SCM_BOOL (SCM_BYTECODE_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0,
- (SCM code),
-"")
-#define FUNC_NAME s_scm_make_bytecode
-{
- int i, size, len, offset;
- SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode;
- SCM *old, *new, *address;
-
- /* Type check */
- SCM_VALIDATE_VECTOR (1, code);
- SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2);
- header = SCM_VELTS (code)[0];
- body = SCM_VELTS (code)[1];
- SCM_VALIDATE_VECTOR (1, header);
- SCM_VALIDATE_VECTOR (2, body);
- SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5);
- nreqs = SCM_VELTS (header)[0];
- restp = SCM_VELTS (header)[1];
- nvars = SCM_VELTS (header)[2];
- nexts = SCM_VELTS (header)[3];
- exts = SCM_VELTS (header)[4];
- SCM_VALIDATE_INUM (1, nreqs);
- SCM_VALIDATE_BOOL (2, restp);
- SCM_VALIDATE_INUM (3, nvars);
- SCM_VALIDATE_INUM (4, nexts);
- SCM_VALIDATE_VECTOR (5, exts);
-
- /* Create a new bytecode */
- size = SCM_LENGTH (body);
- old = SCM_VELTS (body);
- bytecode = make_bytecode (size);
- new = SCM_BYTECODE_BASE (bytecode);
-
- /* Initialize the header */
- SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs);
- SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1;
- SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars);
- SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts);
- len = SCM_LENGTH (exts);
- if (len == 0)
- {
- SCM_BYTECODE_EXTS (bytecode) = NULL;
- }
- else
- {
- SCM_BYTECODE_EXTS (bytecode) =
- scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME);
- SCM_BYTECODE_EXTS (bytecode)[0] = len;
- for (i = 0; i < len; i++)
- SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]);
- }
-
- /* Initialize the body */
- for (i = 0; i < size; i++)
- {
- struct scm_instruction *p;
-
- /* Process instruction */
- if (!SCM_SYMBOLP (old[i])
- || !(p = scm_lookup_instruction (SCM_SYMBOL_CHARS (old[i]))))
- SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i]));
- new[i] = SCM_PACK (p->opcode);
-
- /* Process arguments */
- if (p->type == INST_NONE)
- continue;
- if (++i >= size)
- SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL);
- switch (p->type)
- {
- case INST_NONE:
- /* never come here */
- case INST_INUM:
- SCM_VALIDATE_INUM (1, old[i]);
- /* fall through */
- case INST_SCM:
- /* just copy */
- new[i] = old[i];
- break;
- case INST_TOP:
- /* top-level variable */
- SCM_VALIDATE_SYMBOL (1, old[i]);
- new[i] = lookup_variable (old[i]);
- break;
- case INST_EXT:
- /* just copy for now */
- SCM_VALIDATE_CONS (1, old[i]);
- SCM_VALIDATE_INUM (1, SCM_CAR (old[i]));
- SCM_VALIDATE_INUM (1, SCM_CDR (old[i]));
- new[i] = old[i];
- break;
- case INST_CODE:
- /* another bytecode */
- new[i] = scm_make_bytecode (old[i]);
- break;
- case INST_ADDR:
- /* real address */
- SCM_VALIDATE_INUM (1, old[i]);
- /* Without the following intermediate variables, type conversion
- fails on my machine. Casting doesn't work well, why? */
- offset = SCM_INUM (old[i]);
- address = new + offset;
- new[i] = SCM_VM_MAKE_ADDRESS (address);
- break;
- }
- }
- return bytecode;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0,
- (SCM bytecode),
-"")
-#define FUNC_NAME s_scm_bytecode_decode
-{
- int i, size, offset;
- SCM code, *old, *new;
-
- SCM_VALIDATE_BYTECODE (1, bytecode);
-
- size = SCM_BYTECODE_SIZE (bytecode);
- old = SCM_BYTECODE_BASE (bytecode);
- code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
- new = SCM_VELTS (code);
-
- for (i = 0; i < size; i++)
- {
- struct scm_instruction *p;
-
- /* Process instruction */
- p = SCM_INSTRUCTION (old[i]);
- if (!p)
- {
- broken:
- SCM_MISC_ERROR ("Broken bytecode", SCM_EOL);
- }
- new[i] = scm_instruction_name (p->obj);
-
- /* Process arguments */
- if (p->type == INST_NONE)
- continue;
- if (++i >= size)
- goto broken;
- switch (p->type)
- {
- case INST_NONE:
- /* never come here */
- case INST_INUM:
- case INST_SCM:
- case INST_EXT:
- /* just copy */
- new[i] = old[i];
- break;
- case INST_TOP:
- /* top-level variable */
- new[i] = SCM_CAR (old[i]);
- break;
- case INST_CODE:
- /* another bytecode */
- new[i] = scm_bytecode_decode (old[i]);
- break;
- case INST_ADDR:
- /* program address */
- offset = SCM_VM_ADDRESS (old[i]) - old;
- new[i] = SCM_MAKINUM (offset);
- break;
- }
- }
- return code;
-}
-#undef FUNC_NAME
-
-
-/*
- * Program
- */
-
-static long scm_program_tag;
-
-static SCM
-make_program (SCM code, SCM env)
-{
- SCM_RETURN_NEWSMOB2 (scm_program_tag, SCM_UNPACK (code), SCM_UNPACK (env));
-}
-
-static SCM
-mark_program (SCM program)
-{
- scm_gc_mark (SCM_PROGRAM_CODE (program));
- return SCM_PROGRAM_ENV (program);
-}
-
-static SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-static SCM make_vm (int stack_size);
-
-static SCM
-apply_program (SCM program, SCM args)
-{
- return scm_vm_apply (make_vm (VM_DEFAULT_STACK_SIZE), program, args);
-}
-
-static void
-init_program_type ()
-{
- scm_program_tag = scm_make_smob_type ("program", 0);
- scm_set_smob_mark (scm_program_tag, mark_program);
- scm_set_smob_print (scm_program_tag, scm_smob_print_with_name);
- scm_set_smob_apply (scm_program_tag, apply_program, 0, 0, 1);
-}
-
-/* Scheme interface */
-
-SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
- (SCM obj),
-"")
-#define FUNC_NAME s_scm_program_p
-{
- return SCM_BOOL (SCM_PROGRAM_P (obj));
-}
-#undef FUNC_NAME
-SCM_DEFINE (scm_make_program, "make-program", 2, 0, 0,
- (SCM bytecode, SCM parent),
-"")
-#define FUNC_NAME s_scm_make_program
-{
- SCM_VALIDATE_BYTECODE (1, bytecode);
- return make_program (bytecode, parent);
-}
-#undef FUNC_NAME
+ p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame");
+ p->program = SCM_VM_FRAME_PROGRAM (fp);
+ p->dynamic_link = make_vm_debug_frame (SCM_VM_FRAME_ADDRESS
+ (SCM_VM_FRAME_DYNAMIC_LINK (fp)));
-SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
- (SCM program),
-"")
-#define FUNC_NAME s_scm_program_code
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_CODE (program);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
- (SCM program),
-"")
-#define FUNC_NAME s_scm_program_base
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return SCM_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program));
-}
-#undef FUNC_NAME
-
-
-/*
- * VM Frame
- */
-
-static long scm_vm_frame_tag;
-
-/* This is used for debugging */
-struct scm_vm_frame {
- int size;
- SCM program;
- SCM variables;
- SCM dynamic_link;
- SCM external_link;
- SCM stack_pointer;
- SCM return_address;
-};
-
-#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ)
-#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR))
-#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P)
-
-static SCM
-make_vm_frame (SCM *fp)
-{
- int i;
- int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp));
- struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame");
- p->program = SCM_VM_FRAME_PROGRAM (fp);
- p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp);
- p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (fp);
- p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp);
- p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp);
-
- if (!SCM_FALSEP (p->dynamic_link))
- p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link));
-
- size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program);
+ size = SCM_PROGRAM_NARGS (p->program) + SCM_PROGRAM_NLOCS (p->program);
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
- SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p);
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_debug_frame, p);
}
static SCM
-mark_vm_frame (SCM frame)
-{
- struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame);
- scm_gc_mark (p->program);
- scm_gc_mark (p->dynamic_link);
- scm_gc_mark (p->external_link);
- return p->variables;
-}
-
-static void
-init_vm_frame_type ()
+vm_debug_frame_mark (SCM obj)
{
- scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0);
- scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame);
+ scm_gc_mark (SCM_VM_DEBUG_FRAME_PROGRAM (obj));
+ scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj));
+ return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj);
}
/* Scheme interface */
SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
-"")
+ "")
#define FUNC_NAME s_scm_frame_p
{
- return SCM_BOOL (SCM_VM_FRAME_P (obj));
+ return SCM_BOOL (SCM_VM_DEBUG_FRAME_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
(SCM frame),
-"")
+ "")
#define FUNC_NAME s_scm_frame_program
{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->program;
+ SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+ return SCM_VM_DEBUG_FRAME_PROGRAM (frame);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
(SCM frame),
-"")
+ "")
#define FUNC_NAME s_scm_frame_variables
{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->variables;
+ SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+ return SCM_VM_DEBUG_FRAME_VARIABLES (frame);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
-"")
+ "")
#define FUNC_NAME s_scm_frame_dynamic_link
{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->dynamic_link;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
- (SCM frame),
-"")
-#define FUNC_NAME s_scm_frame_external_link
-{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->external_link;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
- (SCM frame),
-"")
-#define FUNC_NAME s_scm_frame_stack_pointer
-{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->stack_pointer;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
- (SCM frame),
-"")
-#define FUNC_NAME s_scm_frame_return_address
-{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_VM_FRAME_DATA (frame)->return_address;
+ SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+ return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame);
}
#undef FUNC_NAME
@@ -780,7 +135,11 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
* VM Continuation
*/
-static long scm_vm_cont_tag;
+scm_bits_t scm_tc16_vm_cont;
+
+
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
static SCM
capture_vm_cont (struct scm_vm *vmp)
@@ -789,12 +148,12 @@ capture_vm_cont (struct scm_vm *vmp)
p->stack_size = vmp->stack_limit - vmp->sp;
p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
- p->stack_limit = p->stack_base + p->stack_size - 1;
- p->pc = vmp->pc;
+ p->stack_limit = p->stack_base + p->stack_size - 2;
+ p->ip = vmp->ip;
p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
- SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p);
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
}
static void
@@ -803,20 +162,20 @@ reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
struct scm_vm *p = SCM_VM_CONT_VMP (cont);
if (vmp->stack_size < p->stack_size)
{
- puts ("FIXME: Need to expand");
+ /* puts ("FIXME: Need to expand"); */
abort ();
}
- vmp->pc = p->pc;
+ vmp->ip = p->ip;
vmp->sp = vmp->stack_limit - (int) p->sp;
vmp->fp = vmp->stack_limit - (int) p->fp;
memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
}
static SCM
-mark_vm_cont (SCM cont)
+vm_cont_mark (SCM obj)
{
SCM *p;
- struct scm_vm *vmp = SCM_VM_CONT_VMP (cont);
+ struct scm_vm *vmp = SCM_VM_CONT_VMP (obj);
for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
if (SCM_NIMP (*p))
scm_gc_mark (*p);
@@ -824,21 +183,34 @@ mark_vm_cont (SCM cont)
}
static scm_sizet
-free_vm_cont (SCM cont)
+vm_cont_free (SCM obj)
{
- struct scm_vm *p = SCM_VM_CONT_VMP (cont);
+ struct scm_vm *p = SCM_VM_CONT_VMP (obj);
int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
scm_must_free (p->stack_base);
scm_must_free (p);
return size;
}
-static void
-init_vm_cont_type ()
+
+/*
+ * VM Internal functions
+ */
+
+SCM_SYMBOL (sym_vm_engine, "vm-engine");
+SCM_SYMBOL (sym_vm_error, "vm-error");
+
+static scm_byte_t *
+vm_fetch_length (scm_byte_t *ip, size_t *lenp)
{
- scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0);
- scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont);
- scm_set_smob_free (scm_vm_cont_tag, free_vm_cont);
+ *lenp = *ip++;
+ if (*lenp < 254)
+ return ip;
+ else if (*lenp == 254)
+ *lenp = (*ip++ << 8) + *ip++;
+ else
+ *lenp = (*ip++ << 24) + (*ip++ << 16) + (*ip++ << 8) + *ip++;
+ return ip;
}
@@ -846,61 +218,109 @@ init_vm_cont_type ()
* VM
*/
-static long scm_vm_tag;
+#define VM_DEFAULT_STACK_SIZE (16 * 1024)
+#define VM_MAXIMUM_STACK_SIZE (128 * 1024)
+
+#define VM_REGULAR_ENGINE 0
+#define VM_DEBUG_ENGINE 1
+
+#if 0
+#define VM_NAME vm_regular_engine
+#define VM_ENGINE VM_REGULAR_ENGINE
+#include "vm_engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+#endif
+
+#define VM_NAME vm_debug_engine
+#define VM_ENGINE VM_DEBUG_ENGINE
+#include "vm_engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+
+scm_bits_t scm_tc16_vm;
static SCM
-make_vm (int stack_size)
+make_vm (void)
+#define FUNC_NAME "make_vm"
{
- struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm");
- vmp->stack_size = stack_size;
- vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm");
+ int i;
+ struct scm_vm *vmp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
+ vmp->stack_size = VM_DEFAULT_STACK_SIZE;
+ vmp->stack_base = SCM_MUST_MALLOC (vmp->stack_size * sizeof (SCM));
vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
+ vmp->ip = NULL;
vmp->sp = vmp->stack_limit;
- vmp->ac = SCM_BOOL_F;
- vmp->pc = NULL;
vmp->fp = NULL;
+ vmp->cons = 0;
+ vmp->time = 0;
+ vmp->clock = 0;
vmp->options = SCM_EOL;
- vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1));
- vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1));
- vmp->next_hook = scm_make_hook (SCM_MAKINUM (1));
- vmp->call_hook = scm_make_hook (SCM_MAKINUM (1));
- vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1));
- vmp->return_hook = scm_make_hook (SCM_MAKINUM (1));
- SCM_RETURN_NEWSMOB (scm_vm_tag, vmp);
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ vmp->hooks[i] = SCM_BOOL_F;
+ SCM_RETURN_NEWSMOB (scm_tc16_vm, vmp);
}
+#undef FUNC_NAME
static SCM
-mark_vm (SCM vm)
+vm_mark (SCM obj)
{
- SCM *p;
- struct scm_vm *vmp = SCM_VM_DATA (vm);
- for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
- if (SCM_NIMP (*p))
- scm_gc_mark (*p);
+ int i;
+ SCM *sp, *fp;
+ struct scm_vm *vmp = SCM_VM_DATA (obj);
+
+ /* Mark the stack */
+ sp = vmp->sp;
+ fp = vmp->fp;
+ while (fp)
+ {
+ SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
+ SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp);
+ /* Mark intermediate data */
+ for (; sp < lower; sp++)
+ if (SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+ /* Mark frame data */
+ scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp));
+ /* Mark frame variables */
+ for (sp = fp; sp < upper; sp++)
+ if (SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+ fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp));
+ }
- scm_gc_mark (vmp->ac);
- scm_gc_mark (vmp->boot_hook);
- scm_gc_mark (vmp->halt_hook);
- scm_gc_mark (vmp->next_hook);
- scm_gc_mark (vmp->call_hook);
- scm_gc_mark (vmp->apply_hook);
- scm_gc_mark (vmp->return_hook);
+ /* Mark the options */
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ scm_gc_mark (vmp->hooks[i]);
return vmp->options;
}
-static void
-init_vm_type ()
+static scm_sizet
+vm_free (SCM obj)
+{
+ struct scm_vm *vmp = SCM_VM_DATA (obj);
+ int size = (sizeof (struct scm_vm) + vmp->stack_size * sizeof (SCM));
+ scm_must_free (vmp->stack_base);
+ scm_must_free (vmp);
+ return size;
+}
+
+SCM_SYMBOL (sym_debug, "debug");
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
{
- scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm));
- scm_set_smob_mark (scm_vm_tag, mark_vm);
- scm_set_smob_print (scm_vm_tag, scm_smob_print_with_name);
+ SCM_VALIDATE_PROGRAM (1, program);
+ return vm_engine (vm, program, args);
}
+#undef FUNC_NAME
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
- (),
-"")
+ (void),
+ "")
#define FUNC_NAME s_scm_vm_version
{
return scm_makfrom0str (VERSION);
@@ -909,7 +329,7 @@ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
(SCM obj),
-"")
+ "")
#define FUNC_NAME s_scm_vm_p
{
return SCM_BOOL (SCM_VM_P (obj));
@@ -917,345 +337,267 @@ SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (),
-"")
-#define FUNC_NAME s_scm_make_vm
+ (void),
+ "")
+#define FUNC_NAME s_scm_make_vm,
{
- return make_vm (VM_DEFAULT_STACK_SIZE);
+ return make_vm ();
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0,
+SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_ac
+ "")
+#define FUNC_NAME s_scm_vm_ip
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->ac;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0,
- (SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_pc
-{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc);
+ return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->ip);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
(SCM vm),
-"")
+ "")
#define FUNC_NAME s_scm_vm_sp
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->sp);
+ return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->sp);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
(SCM vm),
-"")
+ "")
#define FUNC_NAME s_scm_vm_fp
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp);
+ return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
+#define VM_DEFINE_HOOK(n) \
+{ \
+ struct scm_vm *vmp; \
+ SCM_VALIDATE_VM (1, vm); \
+ vmp = SCM_VM_DATA (vm); \
+ if (SCM_FALSEP (vmp->hooks[n])) \
+ vmp->hooks[n] = scm_make_hook (SCM_MAKINUM (1)); \
+ return vmp->hooks[n]; \
+}
+
+SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_current_frame
+ "")
+#define FUNC_NAME s_scm_vm_boot_hook
{
- SCM_VALIDATE_VM (1, vm);
- return make_vm_frame (SCM_VM_DATA (vm)->fp);
+ VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0,
- (SCM vm, SCM addr),
-"")
-#define FUNC_NAME s_scm_vm_fetch_code
+SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_halt_hook
{
- SCM *p, list;
- struct scm_instruction *inst;
-
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_INUM (2, addr);
-
- p = SCM_VM_ADDRESS (addr);
-
- inst = SCM_INSTRUCTION (*p);
- if (!inst)
- SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr));
-
- list = SCM_LIST1 (scm_instruction_name (inst->obj));
- if (inst->type != INST_NONE)
- {
- if (inst->type == INST_ADDR)
- {
- p = SCM_CODE_TO_ADDR (p[1]);
- SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p)));
- }
- else
- SCM_SETCDR (list, SCM_LIST1 (p[1]));
- }
- return list;
+ VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0,
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_stack_to_list
+ "")
+#define FUNC_NAME s_scm_vm_next_hook
{
- struct scm_vm *vmp;
- SCM *p, list = SCM_EOL;
-
- SCM_VALIDATE_VM (1, vm);
-
- vmp = SCM_VM_DATA (vm);
- for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
- list = scm_cons (*p, list);
- return list;
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
- (SCM vm, SCM key),
-"")
-#define FUNC_NAME s_scm_vm_option
+SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_enter_hook
{
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_SYMBOL (2, key);
- return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+ VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0,
- (SCM vm, SCM key, SCM val),
-"")
-#define FUNC_NAME s_scm_vm_set_option_x
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_apply_hook
{
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_SYMBOL (2, key);
- SCM_VM_DATA (vm)->options
- = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
- return SCM_UNSPECIFIED;
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_boot_hook
+ "")
+#define FUNC_NAME s_scm_vm_exit_hook
{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->boot_hook;
+ VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_halt_hook
+ "")
+#define FUNC_NAME s_scm_vm_return_hook
{
- SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->halt_hook;
+ VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
- (SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_next_hook
+SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
+ (SCM vm, SCM key),
+ "")
+#define FUNC_NAME s_scm_vm_option
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->next_hook;
+ return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0,
- (SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_call_hook
+SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
+ (SCM vm, SCM key, SCM val),
+ "")
+#define FUNC_NAME s_scm_set_vm_option_x
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->call_hook;
+ SCM_VM_DATA (vm)->options
+ = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_apply_hook
+ "")
+#define FUNC_NAME s_scm_vm_stats
{
+ SCM stats;
+
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->apply_hook;
+
+ stats = scm_c_make_vector (3, SCM_MAKINUM (0));
+ SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->cons);
+ SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->time);
+ SCM_VELTS (stats)[2] = scm_long2num (SCM_VM_DATA (vm)->clock);
+
+ return stats;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+#define VM_CHECK_RUNNING(vm) \
+ if (!SCM_VM_DATA (vm)->ip) \
+ SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
+
+SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
(SCM vm),
-"")
-#define FUNC_NAME s_scm_vm_return_hook
+ "")
+#define FUNC_NAME s_scm_vm_current_frame
{
SCM_VALIDATE_VM (1, vm);
- return SCM_VM_DATA (vm)->return_hook;
+ VM_CHECK_RUNNING (vm);
+ return make_vm_debug_frame (SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
-SCM_SYMBOL (sym_debug, "debug");
+SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_code
+{
+ int i;
+ SCM list;
+ scm_byte_t *ip;
+ struct scm_instruction *p;
-static SCM scm_regular_vm (SCM vm, SCM program);
-static SCM scm_debug_vm (SCM vm, SCM program);
+ SCM_VALIDATE_VM (1, vm);
+ VM_CHECK_RUNNING (vm);
-#define VM_CODE(name) SCM_PACK (scm_lookup_instruction (name)->opcode)
+ ip = SCM_VM_DATA (vm)->ip;
+ p = SCM_INSTRUCTION (*ip);
-SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0,
- (SCM vm, SCM program),
-"")
-#define FUNC_NAME s_scm_vm_run
+ list = SCM_LIST1 (scm_str2symbol (p->name));
+ for (i = 1; i <= p->len; i++)
+ list = scm_cons (SCM_MAKINUM (ip[i]), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_stack
{
- SCM bootcode;
- static SCM template[5];
+ SCM *p;
+ SCM list = SCM_EOL;
SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROGRAM (2, program);
+ VM_CHECK_RUNNING (vm);
- if (SCM_EQ_P (template[0], SCM_PACK (0)))
- {
- template[0] = VM_CODE ("%loadc");
- template[1] = SCM_BOOL_F; /* overwritten */
- template[2] = VM_CODE ("%call");
- template[3] = SCM_MAKINUM (0);
- template[4] = VM_CODE ("%halt");
- }
-
- /* Create a boot program */
- bootcode = make_bytecode (5);
- memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5);
- SCM_BYTECODE_BASE (bootcode)[1] = program;
- SCM_BYTECODE_SIZE (bootcode) = 5;
- SCM_BYTECODE_EXTS (bootcode) = NULL;
- SCM_BYTECODE_NREQS (bootcode) = 0;
- SCM_BYTECODE_RESTP (bootcode) = 0;
- SCM_BYTECODE_NVARS (bootcode) = 0;
- SCM_BYTECODE_NEXTS (bootcode) = 0;
- program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F);
-
- if (SCM_FALSEP (scm_vm_option (vm, sym_debug)))
- return scm_regular_vm (vm, program);
- else
- return scm_debug_vm (vm, program);
+ if (SCM_VM_DATA (vm)->fp)
+ for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1;
+ p >= SCM_VM_DATA (vm)->sp;
+ p--)
+ list = scm_cons (*p, list);
+ return list;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
- (SCM vm, SCM program, SCM args),
-"")
-#define FUNC_NAME s_scm_vm_apply
+SCM_DEFINE (scm_vm_load, "vm-load", 2, 0, 0,
+ (SCM vm, SCM bytes),
+ "")
+#define FUNC_NAME s_scm_vm_load
{
- int len;
- SCM bootcode;
- static SCM template[7];
+ SCM prog;
SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROGRAM (2, program);
- SCM_VALIDATE_LIST_COPYLEN (3, args, len);
+ SCM_VALIDATE_STRING (2, bytes);
- if (SCM_EQ_P (template[0], SCM_PACK (0)))
- {
- template[0] = VM_CODE ("%push-list");
- template[1] = SCM_EOL; /* overwritten */
- template[2] = VM_CODE ("%loadc");
- template[3] = SCM_BOOL_F; /* overwritten */
- template[4] = VM_CODE ("%call");
- template[5] = SCM_MAKINUM (0); /* overwritten */
- template[6] = VM_CODE ("%halt");
- }
-
- /* Create a boot program */
- bootcode = make_bytecode (7);
- memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 7);
- SCM_BYTECODE_BASE (bootcode)[1] = args;
- SCM_BYTECODE_BASE (bootcode)[3] = program;
- SCM_BYTECODE_BASE (bootcode)[5] = SCM_MAKINUM (len);
- SCM_BYTECODE_SIZE (bootcode) = 7;
- SCM_BYTECODE_EXTS (bootcode) = NULL;
- SCM_BYTECODE_NREQS (bootcode) = 0;
- SCM_BYTECODE_RESTP (bootcode) = 0;
- SCM_BYTECODE_NVARS (bootcode) = 0;
- SCM_BYTECODE_NEXTS (bootcode) = 0;
- program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F);
-
- if (SCM_FALSEP (scm_vm_option (vm, sym_debug)))
- return scm_regular_vm (vm, program);
- else
- return scm_debug_vm (vm, program);
+ prog = scm_c_make_program (SCM_STRING_CHARS (bytes),
+ SCM_STRING_LENGTH (bytes),
+ bytes);
+ return scm_vm_apply (vm, prog, SCM_EOL);
}
#undef FUNC_NAME
/*
- * The VM engines
+ * Initialize
*/
-/* We don't want to snarf the engines */
-#ifndef SCM_MAGIC_SNARFER
-
-/* the regular engine */
-#define VM_ENGINE SCM_VM_REGULAR_ENGINE
-#include "vm_engine.c"
-#undef VM_ENGINE
+void
+scm_init_vm (void)
+{
+ SCM mod = scm_resolve_module (scm_read_0str ("(system vm core)"));
+ mod = scm_set_current_module (mod);
-/* the debug engine */
-#define VM_ENGINE SCM_VM_DEBUG_ENGINE
-#include "vm_engine.c"
-#undef VM_ENGINE
+ scm_init_instructions ();
+ scm_init_programs ();
-#endif /* not SCM_MAGIC_SNARFER */
+ scm_tc16_vm_debug_frame = scm_make_smob_type ("vm_frame", 0);
+ scm_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark);
-
-/*
- * Initialize
- */
+ scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
+ scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
+ scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
-static SCM scm_module_vm;
+ scm_tc16_vm = scm_make_smob_type ("vm", 0);
+ scm_set_smob_mark (scm_tc16_vm, vm_mark);
+ scm_set_smob_free (scm_tc16_vm, vm_free);
+ scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
-void
-scm_init_vm ()
-{
- SCM old_module;
-
- /* Initialize the module */
- scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)"));
- old_module = scm_select_module (scm_module_vm);
- init_name_property ();
- init_instruction_type ();
- init_bytecode_type ();
- init_program_type ();
- init_vm_frame_type ();
- init_vm_cont_type ();
- init_vm_type ();
+#ifndef SCM_MAGIC_SNARFER
#include "vm.x"
- scm_select_module (old_module);
-
- {
- struct scm_instruction *p;
- for (p = scm_instruction_table; p->opcode != op_last; p++)
- {
- p->obj = scm_permanent_object (make_instruction (p));
- if (p->restp) p->type = INST_INUM;
- }
- }
-}
+#endif
-void
-scm_init_vm_vm_module ()
-{
- scm_register_module_xxx ("vm vm", (void *) scm_init_vm);
+ scm_set_current_module (mod);
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm.h b/src/vm.h
index 80f82467a..68d83087e 100644
--- a/src/vm.h
+++ b/src/vm.h
@@ -39,192 +39,118 @@
* 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
+#ifndef _VM_H_
+#define _VM_H_
#include <libguile.h>
#include "config.h"
+#include "programs.h"
-
/*
- * Instruction
+ * VM Address
*/
-/* Opcode */
-enum scm_opcode {
-#define VM_INSTRUCTION_TO_OPCODE
-#include "vm_expand.h"
-#include "vm_system.i"
-#include "vm_scheme.i"
-#include "vm_number.i"
-#undef VM_INSTRUCTION_TO_OPCODE
- 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 */
- 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_VM_MAKE_FRAME_ADDRESS(ptr) SCM_PACK (ptr)
+#define SCM_VM_FRAME_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
-#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)
+#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr)
+#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr))
-
/*
- * Bytecode
+ * VM Frame
*/
-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
- */
+ | | <- fp + bp->nargs + bp->nlocs
+ +------------------+
+ | Argument 1 |
+ | Argument 2 |
+ | Local variable 1 |
+ | Local varialbe 2 | <- fp
+ | Program |
+ | Dynamic link |
+ | Return address | <- fp - SCM_VM_FRAME_DATA_SIZE
+ +------------------+
+ | |
+*/
+
+/* Frames are allocated on the stack */
+#define SCM_VM_FRAME_DATA_SIZE 3
+#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i]
+#define SCM_VM_FRAME_PROGRAM(fp) fp[-1]
+#define SCM_VM_FRAME_DYNAMIC_LINK(fp) fp[-2]
+#define SCM_VM_FRAME_RETURN_ADDRESS(fp) fp[-3]
+
+#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \
+ (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp)) \
+ + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
+#define SCM_VM_FRAME_LOWER_ADDRESS(fp) \
+ (fp - SCM_VM_FRAME_DATA_SIZE)
-#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
+ * VM Debug frame
*/
-#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR))
-#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ))
+struct scm_vm_debug_frame {
+ SCM program;
+ SCM variables;
+ SCM dynamic_link;
+};
-
-/*
- * VM External
- */
+extern scm_bits_t scm_tc16_vm_debug_frame;
-/* VM external maintains a set of variables outside of the stack.
- This is used to implement external chain of the environment. */
+#define SCM_VM_DEBUG_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_debug_frame, x)
+#define SCM_VM_DEBUG_FRAME_DATA(f) ((struct scm_vm_debug_frame *) SCM_SMOB_DATA (f))
+#define SCM_VALIDATE_VM_DEBUG_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_DEBUG_FRAME_P)
-#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])
+#define SCM_VM_DEBUG_FRAME_PROGRAM(f) SCM_VM_DEBUG_FRAME_DATA (f)->program
+#define SCM_VM_DEBUG_FRAME_VARIABLES(f) SCM_VM_DEBUG_FRAME_DATA (f)->variables
+#define SCM_VM_DEBUG_FRAME_DYNAMIC_LINK(f) SCM_VM_DEBUG_FRAME_DATA (f)->dynamic_link
-
/*
- * VM Continuation
+ * VM
*/
-#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_BOOT_HOOK 0
+#define SCM_VM_HALT_HOOK 1
+#define SCM_VM_NEXT_HOOK 2
+#define SCM_VM_ENTER_HOOK 3
+#define SCM_VM_APPLY_HOOK 4
+#define SCM_VM_EXIT_HOOK 5
+#define SCM_VM_RETURN_HOOK 6
+#define SCM_VM_NUM_HOOKS 7
-#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP)
-#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT)
+struct scm_vm {
+ scm_byte_t *ip; /* instruction pointer */
+ SCM *sp; /* stack pointer */
+ SCM *fp; /* frame pointer */
+ size_t stack_size; /* stack size */
+ SCM *stack_base; /* stack base address */
+ SCM *stack_limit; /* stack limit address */
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ SCM options; /* options */
+ unsigned long cons; /* cons count */
+ unsigned long time; /* time spent */
+ unsigned long clock; /* bogos clock */
+};
-
-/*
- * VM Frame
- */
+#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-/* VM frame is allocated in the stack */
-/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */
-#define SCM_VM_FRAME_DATA_SIZE 6
-#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_EXTERNAL_LINK(FP) (FP[-4])
-#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-5])
-#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-6])
-
-
-/*
- * VM
- */
+extern SCM scm_make_vm (void);
+extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+extern SCM scm_vm_option_ref (SCM vm, SCM key);
+extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
-/* 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;
-};
+extern SCM scm_vm_current_frame (SCM vm);
-#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)
+extern void scm_init_vm (void);
-/* Engine types */
-#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */
-#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */
+#endif /* _VM_H_ */
-#endif /* not VM_H */
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_engine.c b/src/vm_engine.c
index ab68ce028..bff9825a7 100644
--- a/src/vm_engine.c
+++ b/src/vm_engine.c
@@ -39,80 +39,130 @@
* 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! */
+/* This file is included in vm.c twice */
#include "vm_engine.h"
-/* VM names */
-#undef VM_NAME
-#if VM_ENGINE == SCM_VM_REGULAR_ENGINE
-#define VM_NAME scm_regular_vm
-#else
-#if VM_ENGINE == SCM_VM_DEBUG_ENGINE
-#define VM_NAME scm_debug_vm
-#endif
-#endif
-
static SCM
-VM_NAME (SCM vm, SCM program)
+vm_engine (SCM vm, SCM program, SCM args)
#define FUNC_NAME "vm-engine"
{
- /* Copies of VM registers */
- SCM ac = SCM_PACK (0); /* accumulator */
- SCM *pc = NULL; /* program counter */
- SCM *sp = NULL; /* stack pointer */
- SCM *fp = NULL; /* frame pointer */
+ /* VM registers */
+ register scm_byte_t *ip IP_REG; /* instruction pointer */
+ register SCM *sp SP_REG; /* stack pointer */
+ register SCM *fp FP_REG; /* frame pointer */
/* Cache variables */
- struct scm_vm *vmp = NULL; /* the VM data pointer */
- SCM ext = SCM_BOOL_F; /* the current external frame */
- SCM *stack_base = NULL; /* stack base address */
- SCM *stack_limit = NULL; /* stack limit address */
+ struct scm_vm *vmp = SCM_VM_DATA (vm);/* VM data pointer */
+ struct scm_program *bp = NULL; /* program base pointer */
+ SCM external; /* external environment */
+ SCM *objects = NULL; /* constant objects */
+ SCM *stack_base = vmp->stack_base; /* stack base address */
+ SCM *stack_limit = vmp->stack_limit; /* stack limit address */
/* Internal variables */
- int nargs = 0; /* the number of arguments */
- SCM dynwinds = SCM_EOL;
-#if VM_USE_HOOK
+ int nargs = 0;
+ long run_time = scm_c_get_internal_run_time ();
+ // SCM dynwinds = SCM_EOL;
+ SCM err_msg;
+ SCM err_args;
+#if VM_USE_HOOKS
SCM hook_args = SCM_LIST1 (vm);
#endif
+#ifdef HAVE_LABELS_AS_VALUES
/* Jump talbe */
static void *jump_table[] = {
-#define VM_INSTRUCTION_TO_LABEL
+#define VM_INSTRUCTION_TO_LABEL 1
#include "vm_expand.h"
#include "vm_system.i"
#include "vm_scheme.i"
#include "vm_number.i"
+#include "vm_loader.i"
#undef VM_INSTRUCTION_TO_LABEL
};
+#endif
- /* Initialize the VM */
- vmp = SCM_VM_DATA (vm);
- vmp->pc = SCM_PROGRAM_BASE (program);
- vmp->sp = vmp->stack_limit;
- LOAD ();
+ /* Bootcode */
+ scm_byte_t code[3] = {scm_op_call, 0, scm_op_halt};
+ SCM bootcode = scm_c_make_program (code, 3, SCM_BOOL_T);
+ code[1] = scm_ilength (args);
- /* top frame */
- VM_NEW_FRAME (fp, program, SCM_BOOL_F,
- SCM_VM_MAKE_ADDRESS (0),
- SCM_VM_MAKE_ADDRESS (0));
+ /* Initial frame */
+ bp = SCM_PROGRAM_DATA (bootcode);
+ CACHE ();
+ NEW_FRAME ();
+
+ /* Initial arguments */
+ for (; !SCM_NULLP (args); args = SCM_CDR (args))
+ PUSH (SCM_CAR (args));
+ PUSH (program);
/* Let's go! */
- VM_BOOT_HOOK ();
+ BOOT_HOOK ();
#ifndef HAVE_LABELS_AS_VALUES
- vm_start: switch (*pc++) {
+ vm_start:
+ switch (*ip++) {
#endif
#include "vm_expand.h"
#include "vm_system.c"
#include "vm_scheme.c"
#include "vm_number.c"
+#include "vm_loader.c"
#ifndef HAVE_LABELS_AS_VALUES
}
#endif
+ /* Errors */
+ {
+ vm_error_unbound:
+ err_msg = scm_makfrom0str ("Unbound variable: ~A");
+ goto vm_error;
+
+ vm_error_wrong_num_args:
+ err_msg = scm_makfrom0str ("Wrong number of arguments");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_wrong_type_apply:
+ err_msg = scm_makfrom0str ("Wrong type to apply: ~S");
+ err_args = SCM_LIST1 (program);
+ goto vm_error;
+
+#if VM_CHECK_IP
+ vm_error_invalid_address:
+ err_msg = scm_makfrom0str ("Invalid program address");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+ vm_error_stack_overflow:
+ err_msg = scm_makfrom0str ("Stack overflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_stack_underflow:
+ err_msg = scm_makfrom0str ("Stack underflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error:
+ SYNC_ALL ();
+ scm_ithrow (sym_vm_error,
+ SCM_LIST4 (sym_vm_engine, err_msg, err_args,
+ scm_vm_current_frame (vm)),
+ 1);
+ }
+
abort (); /* never reached */
}
#undef FUNC_NAME
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_engine.h b/src/vm_engine.h
index 151e5969c..6d4f41391 100644
--- a/src/vm_engine.h
+++ b/src/vm_engine.h
@@ -45,80 +45,72 @@
* 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
+#define VM_OPTION(regular,debug) debug
-#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
+#define VM_USE_HOOKS VM_OPTION (0, 1) /* Various hooks */
+#define VM_USE_CLOCK VM_OPTION (0, 1) /* Bogos clock */
+#define VM_CHECK_IP VM_OPTION (0, 0) /* Check IP */
/*
- * Type checking
+ * Registers
*/
-#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
-
-
-/*
- * Top-level variable
- */
+/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
-#define VM_VARIABLE_REF(VAR) SCM_CDDR (VAR)
-#define VM_VARIABLE_SET(VAR,VAL) SCM_SETCDR (SCM_CDR (VAR), VAL)
+ Some compilers underestimate the use of the local variables representing
+ the abstract machine registers, and don't put them in hardware registers,
+ which slows down the interpreter considerably.
+ For GCC, I have hand-assigned hardware registers for several architectures.
+*/
-#undef VM_ASSERT_BOUND
-#if VM_CHECK_BINDING
-#define VM_ASSERT_BOUND(VAR) \
- if (SCM_UNBNDP (VM_VARIABLE_REF (VAR))) \
- SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CADR (VAR)))
+#ifdef __GNUC__
+#ifdef __mips__
+#define IP_REG asm("$16")
+#define SP_REG asm("$17")
+#define FP_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define IP_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define FP_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define IP_REG asm("r9")
+#define SP_REG asm("r10")
+#define FP_REG asm("r11")
#else
-#define VM_ASSERT_BOUND(CELL)
+#define IP_REG asm("$9")
+#define SP_REG asm("$10")
+#define FP_REG asm("$11")
+#endif
+#endif
+#ifdef __i386__
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
#endif
@@ -126,239 +118,221 @@
* 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)
+#undef RUN_HOOK
+#if VM_USE_HOOKS
+#define RUN_HOOK(h) \
+{ \
+ if (!SCM_FALSEP (h)) \
+ { \
+ SYNC (); \
+ scm_c_run_hook (h, hook_args); \
+ } \
+}
#else
-#define VM_APPLY_HOOK()
+#define RUN_HOOK(h)
#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
+#define BOOT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_BOOT_HOOK])
+#define HALT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_HALT_HOOK])
+#define NEXT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_NEXT_HOOK])
+#define ENTER_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_ENTER_HOOK])
+#define APPLY_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_APPLY_HOOK])
+#define EXIT_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_EXIT_HOOK])
+#define RETURN_HOOK() RUN_HOOK (vmp->hooks[SCM_VM_RETURN_HOOK])
/*
* Basic operations
*/
-#define LOAD() \
+#define CACHE() \
{ \
- ac = vmp->ac; \
- pc = vmp->pc; \
+ ip = vmp->ip; \
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->ip = ip; \
vmp->sp = sp; \
vmp->fp = fp; \
}
-#define FETCH() *pc++
+#define SYNC_TIME() \
+{ \
+ long cur_time = scm_c_get_internal_run_time (); \
+ vmp->time += cur_time - run_time; \
+ run_time = cur_time; \
+}
-#define CONS(X,Y,Z) \
+#define SYNC_ALL() \
{ \
- SCM cell; \
SYNC (); \
- SCM_NEWCELL (cell); \
- SCM_SET_CELL_OBJECT_0 (cell, Y); \
- SCM_SET_CELL_OBJECT_1 (cell, Z); \
- X = cell; \
+ SYNC_TIME (); \
}
-#define VM_SETUP_ARGS1() SCM a1 = ac;
-#define VM_SETUP_ARGS2() SCM a1, a2; a2 = ac; POP (a1);
-#define VM_SETUP_ARGS3() SCM a1, a2, a3; a3 = ac; POP (a2); POP (a1);
-#define VM_SETUP_ARGSN() nargs = SCM_INUM (FETCH ());
-
/*
* Stack operation
*/
-#define PUSH(X) \
-{ \
+#define CHECK_OVERFLOW() \
if (sp < stack_base) \
- SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \
- *sp-- = (X); \
-}
+ goto vm_error_stack_overflow
+
+#define CHECK_UNDERFLOW() \
+ if (sp > stack_limit) \
+ goto vm_error_stack_underflow
-#define POP(X) \
+#define PUSH(x) do { CHECK_OVERFLOW (); *--sp = x; } while (0)
+#define DROP() do { CHECK_UNDERFLOW (); sp++; } while (0)
+#define POP(x) do { x = *sp; DROP (); } while (0)
+
+#define CONS(x,y,z) \
{ \
- if (sp == stack_limit) \
- SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \
- (X) = *++sp; \
+ SCM cell; \
+ SYNC () \
+ SCM_NEWCELL (cell); \
+ SCM_SET_CELL_OBJECT_0 (cell, y); \
+ SCM_SET_CELL_OBJECT_1 (cell, z); \
+ x = cell; \
}
-#define POP_LIST(N,L) \
-{ \
- while (N-- > 0) \
+#define POP_LIST(n) \
+do { \
+ int i; \
+ SCM l = SCM_EOL; \
+ for (i = 0; i < n; i++) \
+ CONS (l, sp[i], l); \
+ sp += n - 1; \
+ *sp = l; \
+} while (0)
+
+#define POP_LIST_MARK() \
+do { \
+ SCM x; \
+ SCM l = SCM_EOL; \
+ POP (x); \
+ while (!SCM_UNBNDP (x)) \
{ \
- SCM obj; \
- POP (obj); \
- CONS (L, obj, L); \
+ CONS (l, x, l); \
+ POP (x); \
} \
-}
+ PUSH (l); \
+} while (0)
/*
- * Frame allocation
+ * Instruction operation
*/
-/* nargs = the number of arguments */
-#define VM_FRAME_INIT_ARGS(PROG,NREQS,RESTP) \
-{ \
- if (RESTP) \
- /* have a rest argument */ \
- { \
- SCM list; \
- if (nargs < NREQS) \
- scm_wrong_num_args (PROG); \
- \
- /* Construct the rest argument list */ \
- nargs -= NREQS; /* the number of rest arguments */ \
- list = SCM_EOL; /* list of the rest arguments */ \
- POP_LIST (nargs, list); \
- PUSH (list); \
- } \
- else \
- /* not have a rest argument */ \
- { \
- if (nargs != NREQS) \
- scm_wrong_num_args (PROG); \
- } \
-}
+#define FETCH() (*ip++)
+#define FETCH2() (((int) FETCH () << 8) + (int) FETCH ())
-#undef VM_FRAME_INIT_LOCAL_VARIABLES
-#if VM_INIT_LOCAL_VARIABLES
-/* This is necessary when creating frame objects for debugging */
-#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS) \
-{ \
- int i; \
- for (i = 0; i < NVARS; i++) \
- SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \
-}
+#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
+
+#undef CLOCK
+#if VM_USE_CLOCK
+#define CLOCK(n) vmp->clock += n
#else
-#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS)
+#define CLOCK(n)
#endif
-#define VM_FRAME_INIT_EXTERNAL_VARIABLES(FP,PROG) \
-{ \
- int *exts = SCM_PROGRAM_EXTS (PROG); \
- if (exts) \
- { \
- /* Export variables */ \
- int n = exts[0]; \
- while (n-- > 0) \
- SCM_VM_EXTERNAL_VARIABLE (ext, n) \
- = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \
- } \
+#undef NEXT_CHECK
+#if VM_CHECK_IP
+#define NEXT_CHECK() \
+{ \
+ scm_byte_t *base = bp->base; \
+ if (ip < base || ip >= base + bp->size) \
+ goto vm_error_invalid_address; \
}
+#else
+#define NEXT_CHECK()
+#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 */ \
- int nexts = SCM_PROGRAM_NEXTS (PROG); /* the number of external vars */ \
- \
- VM_FRAME_INIT_ARGS (PROG, nreqs, restp); \
- \
- /* Allocate the new frame */ \
- 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; \
- \
- /* Setup the new external frame */ \
- if (!SCM_FALSEP (SCM_PROGRAM_ENV (PROG))) \
- ext = SCM_PROGRAM_ENV (PROG); /* Use program's environment */ \
- if (nexts) \
- { \
- SCM new = SCM_VM_MAKE_EXTERNAL (nexts); /* new external */ \
- SCM_VM_EXTERNAL_LINK (new) = ext; \
- ext = new; \
- } \
- \
- /* Setup the new frame */ \
- SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \
- SCM_VM_FRAME_PROGRAM (FP) = PROG; \
- SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \
- SCM_VM_FRAME_EXTERNAL_LINK (FP) = ext; \
- SCM_VM_FRAME_STACK_POINTER (FP) = SP; \
- SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \
- VM_FRAME_INIT_LOCAL_VARIABLES (FP, nvars); \
- VM_FRAME_INIT_EXTERNAL_VARIABLES (FP, PROG); \
+#undef NEXT_JUMP
+#ifdef HAVE_LABELS_AS_VALUES
+#define NEXT_JUMP() goto *jump_table[FETCH ()]
+#else
+#define NEXT_JUMP() goto vm_start
+#endif
+
+#define NEXT \
+{ \
+ CLOCK (1); \
+ NEXT_CHECK (); \
+ NEXT_HOOK (); \
+ NEXT_JUMP (); \
}
/*
- * Goto next
+ * Function support
*/
-#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
+#define ARGS1(a1) SCM a1 = sp[0];
+#define ARGS2(a1,a2) SCM a1 = sp[1], a2 = sp[0]; sp++;
+#define ARGS3(a1,a2,a3) SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
+#define ARGSN(an) int an = FETCH ();
-#undef VM_GOTO_NEXT
-#if HAVE_LABELS_AS_VALUES
-#define VM_GOTO_NEXT() goto *jump_table[SCM_UNPACK (FETCH ())]
-#else /* not HAVE_LABELS_AS_VALUES */
-#define VM_GOTO_NEXT() goto vm_start
-#endif
+#define RETURN(x) { *sp = x; NEXT; }
-#define NEXT \
+
+/*
+ * Frame allocation
+ */
+
+#define NEW_FRAME() \
{ \
- VM_PROGRAM_COUNTER_CHECK (); \
- VM_NEXT_HOOK (); \
- VM_GOTO_NEXT (); \
+ SCM ra = SCM_VM_MAKE_FRAME_ADDRESS (ip); \
+ SCM dl = SCM_VM_MAKE_BYTE_ADDRESS (fp); \
+ ip = bp->base; \
+ fp = sp - bp->nlocs; \
+ sp = SCM_VM_FRAME_LOWER_ADDRESS (fp); \
+ CHECK_OVERFLOW (); \
+ SCM_VM_FRAME_PROGRAM (fp) = program; \
+ SCM_VM_FRAME_DYNAMIC_LINK (fp) = dl; \
+ SCM_VM_FRAME_RETURN_ADDRESS (fp) = ra; \
+}
+
+#define FREE_FRAME() \
+{ \
+ sp = fp + bp->nargs + bp->nlocs; \
+ ip = SCM_VM_BYTE_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (fp)); \
+ fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp)); \
}
-/* Just an abbreviation */
-#define RETURN(X) { ac = (X); NEXT; }
+#define INIT_ARGS() \
+{ \
+ if (bp->nrest) \
+ { \
+ int n = nargs - bp->nargs - 1; \
+ if (n < 0) \
+ goto vm_error_wrong_num_args; \
+ POP_LIST (n); \
+ } \
+ else \
+ { \
+ if (nargs != bp->nargs) \
+ goto vm_error_wrong_num_args; \
+ } \
+}
+
+#define INIT_VARIABLES() \
+{ \
+ int i; \
+ for (i = 0; i < bp->nlocs; i++) \
+ SCM_VM_FRAME_VARIABLE (fp, i) = SCM_UNDEFINED; \
+}
+
+#define CACHE_PROGRAM() \
+ bp = SCM_PROGRAM_DATA (program); \
+ objects = SCM_VELTS (bp->objs); \
+ external = bp->external;
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_expand.h b/src/vm_expand.h
index 1eeea817e..590759399 100644
--- a/src/vm_expand.h
+++ b/src/vm_expand.h
@@ -42,52 +42,58 @@
#include "config.h"
#ifndef VM_LABEL
-#define VM_LABEL(TAG) l_##TAG##
-#define VM_OPCODE(TAG) op_##TAG##
+#define VM_LABEL(tag) l_##tag
+#define VM_OPCODE(tag) scm_op_##tag
#ifdef HAVE_LABELS_AS_VALUES
-#define VM_TAG(TAG) VM_LABEL(TAG):
-#define VM_ADDR(TAG) &&VM_LABEL(TAG)
+#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
+#define VM_TAG(tag) case VM_OPCODE(tag):
+#define VM_ADDR(tag) NULL
#endif /* not HAVE_LABELS_AS_VALUES */
#endif /* VM_LABEL */
-#undef SCM_DEFINE_INSTRUCTION
-#undef SCM_DEFINE_VM_FUNCTION
+#undef VM_DEFINE_INSTRUCTION
+#undef VM_DEFINE_FUNCTION
#ifdef VM_INSTRUCTION_TO_TABLE
/*
* These will go to scm_instruction_table in vm.c
*/
-#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \
- {VM_OPCODE(TAG), TYPE, NAME, SCM_PACK (0), NULL, 0, 0},
-#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \
- {VM_OPCODE(TAG), INST_NONE, NAME, SCM_PACK (0), SNAME, NARGS, RESTP},
+#define VM_DEFINE_INSTRUCTION(tag,name,len) \
+ {VM_OPCODE (tag), name, len},
+#define VM_DEFINE_FUNCTION(tag,name,nargs) \
+ {VM_OPCODE (tag), name, 0},
#else
#ifdef VM_INSTRUCTION_TO_LABEL
/*
* These will go to jump_table in vm_engine.c
*/
-#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_ADDR(TAG),
-#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_ADDR(TAG),
+#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_ADDR (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
#else
#ifdef VM_INSTRUCTION_TO_OPCODE
/*
* These will go to scm_opcode in vm.h
*/
-#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_OPCODE(TAG),
-#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_OPCODE(TAG),
+#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_OPCODE (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
#else /* Otherwise */
/*
* 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)
+#define VM_DEFINE_INSTRUCTION(tag,name,len) VM_TAG (tag)
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
#endif /* VM_INSTRUCTION_TO_OPCODE */
#endif /* VM_INSTRUCTION_TO_LABEL */
#endif /* VM_INSTRUCTION_TO_TABLE */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_loader.c b/src/vm_loader.c
new file mode 100644
index 000000000..1dd3eb453
--- /dev/null
+++ b/src/vm_loader.c
@@ -0,0 +1,133 @@
+/* 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_DEFINE_INSTRUCTION (load_integer, "load-integer", -1)
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SCM_MISC_ERROR ("Not implemented yet", SCM_EOL);
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1)
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ PUSH (scm_mem2symbol (ip, len));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (load_string, "load-string", -1)
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ PUSH (scm_makfromstr (ip, len, 0));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1)
+{
+ SCM sym;
+ size_t len;
+ FETCH_LENGTH (len);
+ sym = scm_mem2symbol (ip, len);
+ PUSH (scm_make_keyword_from_dash_symbol (sym));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (load_module, "load-module", -1)
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ PUSH (scm_c_lookup_env (scm_mem2symbol (ip, len)));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (load_program, "load-program", -1)
+{
+ size_t len;
+ SCM prog, x;
+
+ FETCH_LENGTH (len);
+ prog = scm_c_make_program (ip, len, program);
+
+ x = sp[0];
+ if (SCM_INUMP (x))
+ {
+ int i = SCM_INUM (x);
+ SCM_PROGRAM_NARGS (prog) = i >> 5; /* 6-5 bits */
+ SCM_PROGRAM_NREST (prog) = (i >> 4) & 1; /* 4 bit */
+ SCM_PROGRAM_NLOCS (prog) = i & 15; /* 3-0 bits */
+ }
+ else
+ {
+ SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[3]);
+ SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
+ SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[1]);
+ if (SCM_VECTORP (x))
+ SCM_PROGRAM_OBJS (prog) = x;
+ sp += 3;
+ }
+
+ ip += len;
+ *sp = prog;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link, "link", 0)
+{
+ sp[1] = scm_c_env_vcell (sp[1], sp[0], 1);
+ DROP ();
+ NEXT;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_number.c b/src/vm_number.c
index cc7b63ad0..adc16e060 100644
--- a/src/vm_number.c
+++ b/src/vm_number.c
@@ -41,158 +41,128 @@
/* This file is included in vm_engine.c */
-#define FUNC2(CFUNC,SFUNC) \
-{ \
- VM_SETUP_ARGS2 (); \
- if (SCM_INUMP (a1) && SCM_INUMP (a2)) \
- { \
- int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \
- if (SCM_FIXABLE (n)) \
- RETURN (SCM_MAKINUM (n)); \
- } \
- RETURN (SFUNC (a1, a2)); \
+
+/*
+ * Predicates
+ */
+
+#undef PRED
+#define PRED(ctest,stest) \
+{ \
+ ARGS1 (a1); \
+ if (SCM_INUMP (a1)) \
+ RETURN (SCM_BOOL (ctest)); \
+ RETURN (stest (a1)); \
}
-#define REL2(CREL,SREL) \
+VM_DEFINE_FUNCTION (zero, "zero?", 1)
+{
+ PRED (SCM_INUM (a1) == 0, scm_zero_p);
+}
+
+
+/*
+ * Relational tests
+ */
+
+#undef REL
+#define REL(crel,srel) \
{ \
- VM_SETUP_ARGS2 (); \
+ ARGS2 (a1, a2); \
if (SCM_INUMP (a1) && SCM_INUMP (a2)) \
- RETURN (SCM_BOOL (SCM_INUM (a1) CREL SCM_INUM (a2))); \
- RETURN (SREL (a1, a2)); \
+ RETURN (SCM_BOOL (SCM_INUM (a1) crel SCM_INUM (a2))); \
+ RETURN (srel (a1, a2)); \
}
-SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0)
+VM_DEFINE_FUNCTION (ee, "ee?", 2)
{
- VM_SETUP_ARGS1 ();
- if (SCM_INUMP (a1))
- RETURN (SCM_BOOL (SCM_EQ_P (a1, SCM_INUM0)));
- RETURN (scm_zero_p (a1));
+ REL (==, scm_num_eq_p);
}
-SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0)
+VM_DEFINE_FUNCTION (lt, "lt?", 2)
{
- VM_SETUP_ARGS1 ();
- if (SCM_INUMP (a1))
- {
- int n = SCM_INUM (a1) + 1;
- if (SCM_FIXABLE (n))
- RETURN (SCM_MAKINUM (n));
- }
- RETURN (scm_sum (a1, SCM_MAKINUM (1)));
+ REL (<, scm_less_p);
}
-SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0)
+VM_DEFINE_FUNCTION (le, "le?", 2)
{
- VM_SETUP_ARGS1 ();
- if (SCM_INUMP (a1))
- {
- int n = SCM_INUM (a1) - 1;
- if (SCM_FIXABLE (n))
- RETURN (SCM_MAKINUM (n));
- }
- RETURN (scm_difference (a1, SCM_MAKINUM (1)));
+ REL (<=, scm_leq_p);
}
-SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1)
+VM_DEFINE_FUNCTION (gt, "gt?", 2)
{
- VM_SETUP_ARGSN ();
- ac = SCM_MAKINUM (0);
- while (nargs-- > 0)
- {
- SCM x;
- POP (x);
- if (SCM_INUMP (ac) && SCM_INUMP (x))
- {
- int n = SCM_INUM (ac) + SCM_INUM (x);
- if (SCM_FIXABLE (n))
- {
- ac = SCM_MAKINUM (n);
- continue;
- }
- }
- ac = scm_sum (ac, x);
- }
- NEXT;
-}
-
-SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0)
-{
- FUNC2 (+, scm_sum);
+ REL (>, scm_gr_p);
}
-SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1)
+VM_DEFINE_FUNCTION (ge, "ge?", 2)
{
- SCM x;
- VM_SETUP_ARGSN ();
- ac = SCM_MAKINUM (0);
- while (nargs-- > 1)
- {
- POP (x);
- if (SCM_INUMP (ac) && SCM_INUMP (x))
- {
- int n = SCM_INUM (ac) + SCM_INUM (x);
- if (SCM_FIXABLE (n))
- {
- ac = SCM_MAKINUM (n);
- continue;
- }
- }
- ac = scm_difference (ac, x);
- }
- POP (x);
- if (SCM_INUMP (ac) && SCM_INUMP (x))
- {
- int n = SCM_INUM (x) - SCM_INUM (ac);
- if (SCM_FIXABLE (n))
- RETURN (SCM_MAKINUM (n));
- }
- RETURN (scm_difference (x, ac));
-}
-
-SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0)
-{
- FUNC2 (-, scm_difference);
+ REL (>=, scm_geq_p);
}
-SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0)
-{
- VM_SETUP_ARGS1 ();
- if (SCM_INUMP (a1))
- {
- int n = - SCM_INUM (a1);
- if (SCM_FIXABLE (n))
- RETURN (SCM_MAKINUM (n));
- }
- RETURN (scm_difference (a1, SCM_UNDEFINED));
+
+/*
+ * Functions
+ */
+
+#undef FUNC1
+#define FUNC1(CEXP,SEXP) \
+{ \
+ ARGS1 (a1); \
+ if (SCM_INUMP (a1)) \
+ { \
+ int n = CEXP; \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_MAKINUM (n)); \
+ } \
+ RETURN (SEXP); \
+}
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC) \
+{ \
+ ARGS2 (a1, a2); \
+ if (SCM_INUMP (a1) && SCM_INUMP (a2)) \
+ { \
+ int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_MAKINUM (n)); \
+ } \
+ RETURN (SFUNC (a1, a2)); \
}
-SCM_DEFINE_VM_FUNCTION (remainder, "remainder", "remainder", 2, 0)
+VM_DEFINE_FUNCTION (neg, "neg", 1)
{
- VM_SETUP_ARGS2 ();
- RETURN (scm_remainder (a1, a2));
+ FUNC1 (- SCM_INUM (a1), scm_difference (a1, SCM_UNDEFINED));
}
-SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0)
+VM_DEFINE_FUNCTION (inc, "inc", 1)
{
- REL2 (<, scm_less_p);
+ FUNC1 (SCM_INUM (a1) + 1, scm_sum (a1, SCM_MAKINUM (1)));
}
-SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0)
+VM_DEFINE_FUNCTION (dec, "dec", 1)
{
- REL2 (>, scm_gr_p);
+ FUNC1 (SCM_INUM (a1) - 1, scm_difference (a1, SCM_MAKINUM (1)));
}
-SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0)
+VM_DEFINE_FUNCTION (add, "add", 2)
{
- REL2 (<=, scm_leq_p);
+ FUNC2 (+, scm_sum);
}
-SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0)
+VM_DEFINE_FUNCTION (sub, "sub", 2)
{
- REL2 (>=, scm_geq_p);
+ FUNC2 (-, scm_difference);
}
-SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0)
+VM_DEFINE_FUNCTION (remainder, "remainder", 2)
{
- REL2 (==, scm_num_eq_p);
+ ARGS2 (a1, a2);
+ RETURN (scm_remainder (a1, a2));
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_scheme.c b/src/vm_scheme.c
index 3b3c6e5ab..99e9e3093 100644
--- a/src/vm_scheme.c
+++ b/src/vm_scheme.c
@@ -41,73 +41,106 @@
/* This file is included in vm_engine.c */
-SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0)
+VM_DEFINE_FUNCTION (not, "not", 1)
{
- VM_SETUP_ARGS1 ();
+ ARGS1 (a1);
+ RETURN (SCM_BOOL (SCM_FALSEP (a1)));
+}
+
+VM_DEFINE_FUNCTION (not_not, "not-not", 1)
+{
+ ARGS1 (a1);
+ RETURN (SCM_BOOL (!SCM_FALSEP (a1)));
+}
+
+VM_DEFINE_FUNCTION (eq, "eq?", 2)
+{
+ ARGS2 (a1, a2);
+ RETURN (SCM_BOOL (SCM_EQ_P (a1, a2)));
+}
+
+VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
+{
+ ARGS2 (a1, a2);
+ RETURN (SCM_BOOL (!SCM_EQ_P (a1, a2)));
+}
+
+VM_DEFINE_FUNCTION (nullp, "null?", 1)
+{
+ ARGS1 (a1);
RETURN (SCM_BOOL (SCM_NULLP (a1)));
}
-SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0)
+VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
{
- VM_SETUP_ARGS2 ();
- CONS (ac, a1, a2);
- NEXT;
+ ARGS1 (a1);
+ RETURN (SCM_BOOL (!SCM_NULLP (a1)));
}
-SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1)
+VM_DEFINE_FUNCTION (pairp, "pair?", 1)
{
- VM_SETUP_ARGSN ();
- ac = SCM_EOL;
- POP_LIST (nargs, ac);
- NEXT;
+ ARGS1 (a1);
+ RETURN (SCM_BOOL (SCM_CONSP (a1)));
}
-SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0)
+VM_DEFINE_FUNCTION (listp, "list?", 1)
{
- VM_SETUP_ARGS1 ();
- SCM_VALIDATE_CONS (0, a1);
- RETURN (SCM_CAR (a1));
+ ARGS1 (a1);
+ RETURN (SCM_BOOL (scm_ilength (a1) >= 0));
}
-SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0)
+VM_DEFINE_FUNCTION (cons, "cons", 2)
{
- VM_SETUP_ARGS1 ();
- SCM_VALIDATE_CONS (0, a1);
- RETURN (SCM_CDR (a1));
+ ARGS2 (a1, a2);
+ CONS (a1, a1, a2);
+ RETURN (a1);
}
-SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0)
+VM_DEFINE_FUNCTION (car, "car", 1)
{
- VM_SETUP_ARGS1 ();
- RETURN (SCM_BOOL (SCM_FALSEP (a1)));
+ ARGS1 (a1);
+ SCM_VALIDATE_CONS (1, a1);
+ RETURN (SCM_CAR (a1));
}
-SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1)
+VM_DEFINE_FUNCTION (cdr, "cdr", 1)
{
- VM_SETUP_ARGSN ();
- ac = SCM_EOL;
- POP_LIST (nargs, ac);
- RETURN (scm_append (ac));
+ ARGS1 (a1);
+ SCM_VALIDATE_CONS (1, a1);
+ RETURN (SCM_CDR (a1));
}
-SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1)
+VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
{
- VM_SETUP_ARGSN ();
- ac = SCM_EOL;
- POP_LIST (nargs, ac);
- RETURN (scm_append_x (ac));
+ ARGS2 (a1, a2);
+ SCM_VALIDATE_CONS (1, a1);
+ SCM_SETCAR (a1, a2);
+ RETURN (SCM_UNSPECIFIED);
}
-SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0)
+VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
{
- VM_SETUP_ARGS3 ();
- dynwinds = SCM_EOL;
+ ARGS2 (a1, a2);
+ SCM_VALIDATE_CONS (1, a1);
+ SCM_SETCDR (a1, a2);
+ RETURN (SCM_UNSPECIFIED);
}
-SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0)
+VM_DEFINE_FUNCTION (list, "list", -1)
{
- SYNC (); /* must sync all registers */
- PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */
- nargs = 1; /* the number of arguments */
- goto vm_call;
+ POP_LIST_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_FUNCTION (vector, "vector", -1)
+{
+ POP_LIST_MARK ();
+ *sp = scm_vector (*sp);
+ NEXT;
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/src/vm_system.c b/src/vm_system.c
index de8041d96..3a4431e55 100644
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -41,314 +41,257 @@
/* This file is included in vm_engine.c */
-/*
- * Variable access
- */
-
-#define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET)
-
-#define EXTERNAL_FOCUS(DEPTH) \
-{ \
- int depth = DEPTH; \
- env = ext; \
- while (depth-- > 0) \
- { \
- VM_ASSERT_LINK (env); \
- env = SCM_VM_EXTERNAL_LINK (env); \
- } \
-}
-
-#define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET)
-#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (ext, OFFSET)
-#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (ext), OFFSET)
-#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (ext)), OFFSET)
-
/*
* Basic operations
*/
-/* Must be the first instruction! */
-SCM_DEFINE_INSTRUCTION (nop, "%nop", INST_NONE)
+/* This must be the first instruction! */
+VM_DEFINE_INSTRUCTION (nop, "nop", 0)
{
NEXT;
}
-SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE)
+VM_DEFINE_INSTRUCTION (halt, "halt", 0)
{
- SYNC ();
- VM_HALT_HOOK ();
- return ac;
+ SCM ret = *sp;
+ HALT_HOOK ();
+ FREE_FRAME ();
+ SYNC_ALL ();
+ return ret;
}
-SCM_DEFINE_INSTRUCTION (name, "%name", INST_SCM)
-{
- SCM name = FETCH ();
- if (SCM_NIMP (name))
- scm_set_name_x (ac, name);
- NEXT;
-}
-
-
-/*
- * %push family
- */
-
-SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE)
+VM_DEFINE_INSTRUCTION (drop, "drop", 0)
{
- PUSH (ac);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (push_list, "%push-list", INST_SCM)
+VM_DEFINE_INSTRUCTION (dup, "dup", 0)
{
- SCM list;
- for (list = FETCH (); SCM_NIMP (list); list = SCM_CDR (list))
- PUSH (SCM_CAR (list));
+ PUSH (*sp);
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;
-}
+
+/*
+ * Object creation
+ */
-SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (void, "void", 0)
{
- PUSH (LOCAL_VAR (1));
+ PUSH (SCM_UNSPECIFIED);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT)
+VM_DEFINE_INSTRUCTION (mark, "mark", 0)
{
- SCM env;
- SCM loc = FETCH ();
- EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
- PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))));
+ PUSH (SCM_UNDEFINED);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM)
+VM_DEFINE_INSTRUCTION (make_true, "make-true", 0)
{
- PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
+ PUSH (SCM_BOOL_T);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (make_false, "make-false", 0)
{
- PUSH (EXTERNAL_VAR0 (0));
+ PUSH (SCM_BOOL_F);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0)
{
- PUSH (EXTERNAL_VAR0 (1));
+ PUSH (SCM_EOL);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM)
+VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1)
{
- PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
+ PUSH (SCM_MAKINUM ((signed char) FETCH ()));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0)
{
- PUSH (EXTERNAL_VAR1 (0));
+ PUSH (SCM_MAKINUM (0));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0)
{
- PUSH (EXTERNAL_VAR1 (1));
+ PUSH (SCM_MAKINUM (1));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM)
+VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
{
- PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
+ PUSH (SCM_MAKINUM ((signed short) FETCH2 ()));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP)
+VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1)
{
- ac = FETCH ();
- VM_ASSERT_BOUND (ac);
- PUSH (VM_VARIABLE_REF (ac));
+ PUSH (SCM_MAKE_CHAR (FETCH ()));
NEXT;
}
/*
- * %load family
+ * Variable access
*/
-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))));
-}
+#define OBJECT_REF(i) objects[i]
+#define OBJECT_SET(i,o) objects[i] = o
-SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM)
-{
- RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
-}
+#define LOCAL_REF(i) SCM_VM_FRAME_VARIABLE (fp, i)
+#define LOCAL_SET(i,o) SCM_VM_FRAME_VARIABLE (fp, i) = o
-SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE)
-{
- RETURN (EXTERNAL_VAR0 (0));
-}
+#define VARIABLE_REF(v) SCM_CDR (v)
+#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
-SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (external, "external", 1)
{
- RETURN (EXTERNAL_VAR0 (1));
+ int n = FETCH ();
+ while (n-- > 0)
+ CONS (external, SCM_UNDEFINED, external);
+ NEXT;
}
-SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM)
-{
- RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
-}
+/* ref */
-SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1)
{
- RETURN (EXTERNAL_VAR1 (0));
+ PUSH (OBJECT_REF (FETCH ()));
+ NEXT;
}
-SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (object_ref_2, "object-ref*2", 2)
{
- RETURN (EXTERNAL_VAR1 (1));
+ PUSH (OBJECT_REF (FETCH2 ()));
+ NEXT;
}
-SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM)
+VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1)
{
- RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
+ PUSH (LOCAL_REF (FETCH ()));
+ NEXT;
}
-SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP)
+VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0)
{
- ac = FETCH ();
- VM_ASSERT_BOUND (ac);
- RETURN (VM_VARIABLE_REF (ac));
-}
-
-
-/*
- * %save family
- */
-
-SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM)
-{
- LOCAL_VAR (SCM_INUM (FETCH ())) = ac;
+ PUSH (LOCAL_REF (0));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (local_ref_2, "local-ref*2", 2)
{
- LOCAL_VAR (0) = ac;
+ PUSH (LOCAL_REF (FETCH2 ()));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
{
- LOCAL_VAR (1) = ac;
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ e = SCM_CDR (e);
+ PUSH (SCM_CAR (e));
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT)
+VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1)
{
- SCM env;
- SCM loc = FETCH ();
- EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
- EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac;
+ int i = FETCH ();
+ SCM o, x = OBJECT_REF (i);
+ o = VARIABLE_REF (x);
+ if (SCM_UNBNDP (o))
+ {
+ err_args = SCM_LIST1 (SCM_CAR (x));
+ goto vm_error_unbound;
+ }
+ PUSH (o);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM)
+VM_DEFINE_INSTRUCTION (module_ref_2, "module-ref*2", 2)
{
- EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac;
+ int i = FETCH2 ();
+ SCM o, x = OBJECT_REF (i);
+ o = VARIABLE_REF (x);
+ if (SCM_UNBNDP (o))
+ {
+ err_args = SCM_LIST1 (SCM_CAR (x));
+ goto vm_error_unbound;
+ }
+ PUSH (o);
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
{
- EXTERNAL_VAR0 (0) = ac;
+ SCM x = *sp;
+ SCM o = VARIABLE_REF (x);
+ if (SCM_UNBNDP (o))
+ {
+ err_args = SCM_LIST1 (SCM_CAR (x));
+ goto vm_error_unbound;
+ }
+ *sp = o;
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE)
+/* set */
+
+VM_DEFINE_INSTRUCTION (local_set, "local-set", 1)
{
- EXTERNAL_VAR0 (1) = ac;
+ LOCAL_SET (FETCH (), *sp);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_1, "%savee:1", INST_INUM)
+VM_DEFINE_INSTRUCTION (local_set_2, "local-set*2", 2)
{
- EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = ac;
+ LOCAL_SET (FETCH2 (), *sp);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_1_0, "%savee:1:0", INST_NONE)
+VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
{
- EXTERNAL_VAR1 (0) = ac;
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ e = SCM_CDR (e);
+ SCM_SETCAR (e, *sp);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_1_1, "%savee:1:1", INST_NONE)
+VM_DEFINE_INSTRUCTION (module_set, "module-set", 1)
{
- EXTERNAL_VAR1 (1) = ac;
+ int i = FETCH ();
+ SCM x = OBJECT_REF (i);
+ VARIABLE_SET (x, *sp);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM)
+VM_DEFINE_INSTRUCTION (module_set_2, "module-set*2", 2)
{
- EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac;
+ int i = FETCH2 ();
+ SCM x = OBJECT_REF (i);
+ VARIABLE_SET (x, *sp);
+ DROP ();
NEXT;
}
-SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP)
+VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
{
- SCM cell = FETCH ();
- VM_VARIABLE_SET (cell, ac);
+ VARIABLE_SET (sp[0], sp[1]);
+ sp += 2;
NEXT;
}
@@ -357,47 +300,48 @@ SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP)
* branch and jump
*/
-SCM_DEFINE_INSTRUCTION (br_if, "%br-if", INST_ADDR)
+#define BR(p) \
+{ \
+ signed char offset = FETCH (); \
+ if (p) \
+ ip += offset; \
+ DROP (); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 1)
{
- SCM addr = FETCH (); /* must always fetch */
- if (!SCM_FALSEP (ac))
- pc = SCM_VM_ADDRESS (addr);
- NEXT;
+ BR (!SCM_FALSEP (*sp));
}
-SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR)
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1)
{
- SCM addr = FETCH (); /* must always fetch */
- if (SCM_FALSEP (ac))
- pc = SCM_VM_ADDRESS (addr);
- NEXT;
+ BR (SCM_FALSEP (*sp));
}
-SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR)
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1)
{
- SCM addr = FETCH (); /* must always fetch */
- if (SCM_NULLP (ac))
- {
- ac = SCM_BOOL_T;
- pc = SCM_VM_ADDRESS (addr);
- }
- NEXT;
+ BR (SCM_EQ_P (sp[0], sp--[1]));
}
-SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR)
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1)
{
- SCM addr = FETCH (); /* must always fetch */
- if (!SCM_NULLP (ac))
- {
- ac = SCM_BOOL_F;
- pc = SCM_VM_ADDRESS (addr);
- }
- NEXT;
+ BR (!SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1)
+{
+ BR (SCM_NULLP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1)
+{
+ BR (!SCM_NULLP (*sp));
}
-SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR)
+VM_DEFINE_INSTRUCTION (jump, "jump", 1)
{
- pc = SCM_VM_ADDRESS (*pc);
+ ip += (signed char) FETCH ();
NEXT;
}
@@ -406,159 +350,178 @@ SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR)
* Subprogram call
*/
-SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE)
+VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0)
{
- SYNC (); /* must be called before GC */
- RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_EXTERNAL_LINK (fp)));
+ SYNC ();
+ *sp = scm_c_make_vclosure (*sp, external);
+ NEXT;
}
-/* Before:
- ac = program
- pc[0] = the number of arguments
-
- After:
- pc = program's address
-*/
-SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM)
+VM_DEFINE_INSTRUCTION (call, "call", 1)
{
- nargs = SCM_INUM (FETCH ()); /* the number of arguments */
+ POP (program);
+ nargs = FETCH ();
vm_call:
/*
* Subprogram call
*/
- if (SCM_PROGRAM_P (ac))
+ if (SCM_PROGRAM_P (program))
{
- /* Create a new frame */
- SCM *last_fp = fp;
- SCM *last_sp = sp + nargs;
- 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 ();
+ CACHE_PROGRAM ();
+ INIT_ARGS ();
+ NEW_FRAME ();
+ INIT_VARIABLES ();
+ ENTER_HOOK ();
+ APPLY_HOOK ();
NEXT;
}
/*
* Function call
*/
- if (!SCM_FALSEP (scm_procedure_p (ac)))
+ if (!SCM_FALSEP (scm_procedure_p (program)))
{
- /* Construct an argument list */
- SCM list = SCM_EOL;
- POP_LIST (nargs, list);
- RETURN (scm_apply (ac, list, SCM_EOL));
+ POP_LIST (nargs);
+ *sp = scm_apply (program, *sp, SCM_EOL);
+ program = SCM_VM_FRAME_PROGRAM (fp);
+ NEXT;
}
/*
* Continuation call
*/
- if (SCM_VM_CONT_P (ac))
+ if (SCM_VM_CONT_P (program))
{
vm_call_cc:
/* Check the number of arguments */
if (nargs != 1)
- scm_wrong_num_args (ac);
+ scm_wrong_num_args (program);
/* Reinstate the continuation */
- VM_RETURN_HOOK ();
- SCM_VM_REINSTATE_CONT (vmp, ac);
- LOAD ();
- POP (ac); /* return value */
+ EXIT_HOOK ();
+ reinstate_vm_cont (vmp, program);
+ CACHE ();
+ /* We don't need to set the return value here
+ because it is already on the top of the stack. */
NEXT;
}
- SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac));
+ goto vm_error_wrong_type_apply;
}
-/* Before:
- ac = program
- pc[0] = the number of arguments
-
- After:
- pc = program's address
-*/
-SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM)
+VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1)
{
- SCM_TICK; /* allow interrupt here */
- nargs = SCM_INUM (FETCH ()); /* the number of arguments */
+ SCM x;
+ POP (x);
+ nargs = FETCH ();
+
+ SCM_TICK; /* allow interrupt here */
/*
- * Subprogram call
+ * Tail recursive call
*/
- if (SCM_PROGRAM_P (ac))
+ if (SCM_EQ_P (x, program))
{
- 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_FRAME_INIT_ARGS (ac, nreqs, restp);
-
- /* Move arguments */
- nreqs += restp;
- while (nreqs-- > 0)
- {
- SCM obj;
- POP (obj);
- SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj;
- }
-
- VM_FRAME_INIT_EXTERNAL_VARIABLES (fp, ac);
- }
- else
- /* Proper tail call */
+ INIT_ARGS ();
+
+ /* Move arguments */
+ if (bp->nargs)
{
- /* FIXME: Must remove the last frame.
- FIXME: We need to move arguments before that. */
- SCM *last_fp = fp;
- VM_RETURN_HOOK ();
- VM_NEW_FRAME (fp, ac,
- SCM_VM_FRAME_DYNAMIC_LINK (last_fp),
- SCM_VM_FRAME_STACK_POINTER (last_fp),
- SCM_VM_FRAME_RETURN_ADDRESS (last_fp));
- VM_CALL_HOOK ();
+ int i;
+ SCM *base = fp + bp->nlocs;
+ for (i = 0; i < bp->nargs; i++)
+ base[i] = sp[i];
}
- /* Jump to the program */
- pc = SCM_PROGRAM_BASE (ac);
- VM_APPLY_HOOK ();
+ ip = bp->base;
+ sp = SCM_VM_FRAME_LOWER_ADDRESS (fp);
+ APPLY_HOOK ();
NEXT;
}
+ program = x;
+ /*
+ * Proper tail call
+ */
+ if (SCM_PROGRAM_P (program))
+ {
+ int i;
+ int n = SCM_VM_FRAME_LOWER_ADDRESS (fp) - sp;
+ SCM *base = sp;
+
+ /* Exit the current frame */
+ EXIT_HOOK ();
+ FREE_FRAME ();
+
+ /* Move arguments */
+ sp -= n;
+ for (i = 0; i < n; i++)
+ sp[i] = base[i];
+
+ /* Call the program */
+ goto vm_call;
+ }
/*
* Function call
*/
- if (!SCM_FALSEP (scm_procedure_p (ac)))
+ if (!SCM_FALSEP (scm_procedure_p (program)))
{
- /* Construct an argument list */
- SCM list = SCM_EOL;
- POP_LIST (nargs, list);
- ac = scm_apply (ac, list, SCM_EOL);
+ POP_LIST (nargs);
+ *sp = scm_apply (program, *sp, SCM_EOL);
+ program = SCM_VM_FRAME_PROGRAM (fp);
goto vm_return;
}
/*
* Continuation call
*/
- if (SCM_VM_CONT_P (ac))
+ if (SCM_VM_CONT_P (program))
goto vm_call_cc;
- SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac));
+ goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1)
+{
+ SYNC ();
+ PUSH (capture_vm_cont (vmp));
+ POP (program);
+ nargs = 1;
+ goto vm_call;
}
-SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE)
+VM_DEFINE_INSTRUCTION (return, "return", 0)
{
- SCM *last_fp;
+ SCM ret;
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));
- ext = SCM_VM_FRAME_EXTERNAL_LINK (fp);
+ ret = *sp;
+ EXIT_HOOK ();
+ RETURN_HOOK ();
+ FREE_FRAME ();
+
+ /* Cache the last program */
+ program = SCM_VM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ PUSH (ret);
NEXT;
}
+
+
+/*
+ * Exception handling
+ */
+
+VM_DEFINE_INSTRUCTION (raise, "raise", 1)
+{
+}
+
+VM_DEFINE_INSTRUCTION (catch, "catch", 0)
+{
+}
+
+VM_DEFINE_INSTRUCTION (stack_catch, "stach_catch", 0)
+{
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/