mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

New VM.

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-01 05:03:41 +00:00
parent c092937bd5
commit 17e90c5e25
47 changed files with 5599 additions and 2159 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.cvsignore
View file

@ -1,4 +1,4 @@
.cvsignore
misc
libtool
config.log
config.cache

108
ChangeLog
View file

@ -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.

2
Makefile.am
View file

@ -1,4 +1,4 @@
SUBDIRS = src vm doc test
SUBDIRS = src doc module
EXTRA_DIST = acconfig.h

2
THANKS
View file

@ -1 +1 @@
Guile VM is motivated by QScheme.
Guile VM was motivated by QScheme and librep.

4
configure.in
View file

@ -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)

2
module/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

13
module/Makefile.am Normal file
View file

@ -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

8
module/language/ghil/GPKG.def Normal file
View file

@ -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))
)

31
module/language/ghil/spec.scm Normal file
View file

@ -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)
)

111
module/system/base/language.scm Normal file
View file

@ -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")))

222
module/system/base/module.scm Normal file
View file

@ -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)))

98
module/system/base/syntax.scm Normal file
View file

@ -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))))

196
module/system/il/compile.scm Normal file
View file

@ -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))))

266
module/system/il/ghil.scm Normal file
View file

@ -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))))

184
module/system/il/glil.scm Normal file
View file

@ -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))

435
module/system/il/macros.scm Normal file
View file

@ -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)))

506
module/system/repl/command.scm Normal file
View file

@ -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

93
module/system/repl/common.scm Normal file
View file

@ -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

364
module/system/repl/describe.scm Normal file
View file

@ -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

74
module/system/repl/repl.scm Normal file
View file

@ -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))

327
module/system/vm/assemble.scm Normal file
View file

@ -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)))))))))))))

137
module/system/vm/conv.scm Normal file
View file

@ -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))))

35
module/system/vm/core.scm Normal file
View file

@ -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)))))

118
module/system/vm/disasm.scm Normal file
View file

@ -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)))

32
module/system/vm/frame.scm Normal file
View file

@ -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)))

66
module/system/vm/profile.scm Normal file
View file

@ -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))))))))

75
module/system/vm/trace.scm Normal file
View file

@ -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)))

6
src/.cvsignore
View file

@ -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

36
src/Makefile.am
View file

@ -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

250
src/envs.c Normal file
View file

@ -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:
*/

73
src/envs.h Normal file
View file

@ -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:
*/

6
src/guile-compile.in
View file

@ -1,6 +0,0 @@
#!@bindir@/@PACKAGE@ -s
!#
(use-modules (vm compile))
(for-each compile-file (cdr (command-line)))

12
src/guile-vm.c
View file

@ -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 */
}

138
src/instructions.c Normal file
View file

@ -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:
*/

84
src/instructions.h Normal file
View file

@ -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:
*/

209
src/programs.c Normal file
View file

@ -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:
*/

94
src/programs.h Normal file
View file

@ -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:
*/

60
src/test.scm
View file

@ -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"))

1278
src/vm.c
View file

File diff suppressed because it is too large Load diff

256
src/vm.h
View file

@ -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
*/
/* 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_ADDR_TO_CODE(ADDR) SCM_PACK (ADDR)
#define SCM_CODE_TO_ADDR(CODE) ((void *) SCM_UNPACK (CODE))
#define SCM_CODE_TO_DEBUG_ADDR(CODE) instruction_code_to_debug_addr (CODE)
/*
* Bytecode
*/
struct scm_bytecode {
int size; /* the size of the bytecode */
char nreqs; /* the number of required arguments */
char restp; /* have a rest argument or not */
char nvars; /* the number of local variables */
char nexts; /* the number of external variables */
int *exts; /* externalized arguments */
SCM base[0]; /* base address (must be the last!) */
};
#define SCM_BYTECODE_P(OBJ) SCM_SMOB_PREDICATE (scm_bytecode_tag, OBJ)
#define SCM_BYTECODE_DATA(BC) ((struct scm_bytecode *) SCM_SMOB_DATA (BC))
#define SCM_VALIDATE_BYTECODE(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, BYTECODE_P)
#define SCM_BYTECODE_SIZE(BC) SCM_BYTECODE_DATA (BC)->size
#define SCM_BYTECODE_NREQS(BC) SCM_BYTECODE_DATA (BC)->nreqs
#define SCM_BYTECODE_RESTP(BC) SCM_BYTECODE_DATA (BC)->restp
#define SCM_BYTECODE_NVARS(BC) SCM_BYTECODE_DATA (BC)->nvars
#define SCM_BYTECODE_NEXTS(BC) SCM_BYTECODE_DATA (BC)->nexts
#define SCM_BYTECODE_EXTS(BC) SCM_BYTECODE_DATA (BC)->exts
#define SCM_BYTECODE_BASE(BC) SCM_BYTECODE_DATA (BC)->base
extern SCM scm_bytecode_p (SCM obj);
extern SCM scm_make_bytecode (SCM code);
extern SCM scm_bytecode_decode (SCM bytecode);
/*
* Program
*/
#define SCM_MAKE_PROGRAM(CODE,ENV) make_program (CODE, ENV)
#define SCM_PROGRAM_P(OBJ) SCM_SMOB_PREDICATE (scm_program_tag, OBJ)
#define SCM_PROGRAM_CODE(PROG) SCM_CELL_OBJECT_1 (PROG)
#define SCM_PROGRAM_ENV(PROG) SCM_CELL_OBJECT_2 (PROG)
#define SCM_VALIDATE_PROGRAM(POS,PROG) SCM_MAKE_VALIDATE (POS, PROG, PROGRAM_P)
/* Abbreviations */
#define SCM_PROGRAM_SIZE(PROG) SCM_BYTECODE_SIZE (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_NREQS(PROG) SCM_BYTECODE_NREQS (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_RESTP(PROG) SCM_BYTECODE_RESTP (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_NVARS(PROG) SCM_BYTECODE_NVARS (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_NEXTS(PROG) SCM_BYTECODE_NEXTS (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_EXTS(PROG) SCM_BYTECODE_EXTS (SCM_PROGRAM_CODE (PROG))
#define SCM_PROGRAM_BASE(PROG) SCM_BYTECODE_BASE (SCM_PROGRAM_CODE (PROG))
extern SCM scm_program_p (SCM obj);
extern SCM scm_make_program (SCM bytecode, SCM env);
extern SCM scm_program_code (SCM program);
extern SCM scm_program_base (SCM program);
/*
* VM Address
*/
#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR))
#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ))
#define SCM_VM_MAKE_FRAME_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_FRAME_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
/*
* VM External
*/
#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr))
/* VM external maintains a set of variables outside of the stack.
This is used to implement external chain of the environment. */
#define SCM_VM_MAKE_EXTERNAL(SIZE) scm_make_vector (SCM_MAKINUM ((SIZE) + 1), SCM_UNDEFINED)
#define SCM_VM_EXTERNAL_LINK(EXT) (SCM_VELTS (EXT)[0])
#define SCM_VM_EXTERNAL_VARIABLE(EXT,N) (SCM_VELTS (EXT)[(N) + 1])
/*
* VM Continuation
*/
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_cont_tag, OBJ)
#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP)
#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT)
/*
* VM Frame
*/
/* VM frame is allocated in the stack */
/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */
#define SCM_VM_FRAME_DATA_SIZE 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])
/*
| | <- 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)
/*
* VM Debug frame
*/
struct scm_vm_debug_frame {
SCM program;
SCM variables;
SCM dynamic_link;
};
extern scm_bits_t scm_tc16_vm_debug_frame;
#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_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
*/
/* Modify make_vm, mark_vm, and SYNC, too! */
#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
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;
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 */
};
#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)
#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)
/* Engine types */
#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */
#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */
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);
#endif /* not VM_H */
extern SCM scm_vm_current_frame (SCM vm);
extern void scm_init_vm (void);
#endif /* _VM_H_ */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

122
src/vm_engine.c
View file

@ -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:
*/

466
src/vm_engine.h
View file

@ -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
#define VM_OPTION(regular,debug) debug
#if VM_ENGINE == SCM_VM_REGULAR_ENGINE
#define VM_USE_BOOT_HOOK 0
#define VM_USE_HALT_HOOK 0
#define VM_USE_NEXT_HOOK 0
#define VM_USE_CALL_HOOK 0
#define VM_USE_APPLY_HOOK 0
#define VM_USE_RETURN_HOOK 0
#define VM_INIT_LOCAL_VARIABLES 0
#define VM_CHECK_LINK 0
#define VM_CHECK_BINDING 1
#define VM_CHECK_PROGRAM_COUNTER 0
#else
#if VM_ENGINE == SCM_VM_DEBUG_ENGINE
#define VM_USE_BOOT_HOOK 1
#define VM_USE_HALT_HOOK 1
#define VM_USE_NEXT_HOOK 1
#define VM_USE_CALL_HOOK 1
#define VM_USE_APPLY_HOOK 1
#define VM_USE_RETURN_HOOK 1
#define VM_INIT_LOCAL_VARIABLES 1
#define VM_CHECK_LINK 1
#define VM_CHECK_BINDING 1
#define VM_CHECK_PROGRAM_COUNTER 1
#endif
#endif
#undef VM_USE_HOOK
#if VM_USE_BOOT_HOOK || VM_USE_HALT_HOOK || VM_USE_NEXT_HOOK \
|| VM_USE_CALL_HOOK || VM_USE_APPLY_HOOK || VM_USE_RETURN_HOOK
#define VM_USE_HOOK 1
#else
#define VM_USE_HOOK 0
#endif
#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)
/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
Some compilers underestimate the use of the local variables representing
the abstract machine registers, and don't put them in hardware registers,
which slows down the interpreter considerably.
For GCC, I have hand-assigned hardware registers for several architectures.
*/
#ifdef __GNUC__
#ifdef __mips__
#define IP_REG asm("$16")
#define SP_REG asm("$17")
#define FP_REG asm("$18")
#endif
/*
* Top-level variable
*/
#define VM_VARIABLE_REF(VAR) SCM_CDDR (VAR)
#define VM_VARIABLE_SET(VAR,VAL) SCM_SETCDR (SCM_CDR (VAR), VAL)
#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 __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)
#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_BOOT_HOOK()
#define RUN_HOOK(h)
#endif
#undef VM_HALT_HOOK
#if VM_USE_HALT_HOOK
#define VM_HALT_HOOK() SYNC (); scm_c_run_hook (vmp->halt_hook, hook_args)
#else
#define VM_HALT_HOOK()
#endif
#undef VM_NEXT_HOOK
#if VM_USE_NEXT_HOOK
#define VM_NEXT_HOOK() SYNC (); scm_c_run_hook (vmp->next_hook, hook_args)
#else
#define VM_NEXT_HOOK()
#endif
#undef VM_CALL_HOOK
#if VM_USE_CALL_HOOK
#define VM_CALL_HOOK() SYNC (); scm_c_run_hook (vmp->call_hook, hook_args)
#else
#define VM_CALL_HOOK()
#endif
#undef VM_APPLY_HOOK
#if VM_USE_APPLY_HOOK
#define VM_APPLY_HOOK() SYNC (); scm_c_run_hook (vmp->apply_hook, hook_args)
#else
#define VM_APPLY_HOOK()
#endif
#undef VM_RETURN_HOOK
#if VM_USE_RETURN_HOOK
#define VM_RETURN_HOOK() SYNC (); scm_c_run_hook (vmp->return_hook, hook_args)
#else
#define VM_RETURN_HOOK()
#endif
#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 CONS(X,Y,Z) \
#define SYNC_TIME() \
{ \
SCM cell; \
SYNC (); \
SCM_NEWCELL (cell); \
SCM_SET_CELL_OBJECT_0 (cell, Y); \
SCM_SET_CELL_OBJECT_1 (cell, Z); \
X = cell; \
long cur_time = scm_c_get_internal_run_time (); \
vmp->time += cur_time - run_time; \
run_time = cur_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 ());
#define SYNC_ALL() \
{ \
SYNC (); \
SYNC_TIME (); \
}
/*
* 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 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) \
{ \
SCM cell; \
SYNC () \
SCM_NEWCELL (cell); \
SCM_SET_CELL_OBJECT_0 (cell, y); \
SCM_SET_CELL_OBJECT_1 (cell, z); \
x = cell; \
}
#define POP(X) \
{ \
if (sp == stack_limit) \
SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \
(X) = *++sp; \
}
#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(N,L) \
{ \
while (N-- > 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)
/*
* Instruction operation
*/
#define FETCH() (*ip++)
#define FETCH2() (((int) FETCH () << 8) + (int) FETCH ())
#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 CLOCK(n)
#endif
#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
#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 (); \
}
/*
* Function support
*/
#define ARGS1(a1) SCM a1 = sp[0];
#define ARGS2(a1,a2) SCM a1 = sp[1], a2 = sp[0]; sp++;
#define ARGS3(a1,a2,a3) SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
#define ARGSN(an) int an = FETCH ();
#define RETURN(x) { *sp = x; NEXT; }
/*
* Frame allocation
*/
/* nargs = the number of arguments */
#define VM_FRAME_INIT_ARGS(PROG,NREQS,RESTP) \
#define NEW_FRAME() \
{ \
if (RESTP) \
/* have a rest argument */ \
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)); \
}
#define INIT_ARGS() \
{ \
if (bp->nrest) \
{ \
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); \
int n = nargs - bp->nargs - 1; \
if (n < 0) \
goto vm_error_wrong_num_args; \
POP_LIST (n); \
} \
else \
/* not have a rest argument */ \
{ \
if (nargs != NREQS) \
scm_wrong_num_args (PROG); \
if (nargs != bp->nargs) \
goto vm_error_wrong_num_args; \
} \
}
#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) \
#define INIT_VARIABLES() \
{ \
int i; \
for (i = 0; i < NVARS; i++) \
SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \
}
#else
#define VM_FRAME_INIT_LOCAL_VARIABLES(FP,NVARS)
#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]); \
} \
for (i = 0; i < bp->nlocs; i++) \
SCM_VM_FRAME_VARIABLE (fp, i) = SCM_UNDEFINED; \
}
#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); \
}
#define CACHE_PROGRAM() \
bp = SCM_PROGRAM_DATA (program); \
objects = SCM_VELTS (bp->objs); \
external = bp->external;
/*
* Goto next
*/
#undef VM_PROGRAM_COUNTER_CHECK
#if VM_CHECK_PROGRAM_COUNTER
#define VM_PROGRAM_COUNTER_CHECK() \
{ \
SCM prog = SCM_VM_FRAME_PROGRAM (fp); \
if (pc < SCM_PROGRAM_BASE (prog) \
|| pc >= (SCM_PROGRAM_BASE (prog) + SCM_PROGRAM_SIZE (prog))) \
SCM_MISC_ERROR ("VM accessed invalid program address", SCM_EOL); \
}
#else
#define VM_PROGRAM_COUNTER_CHECK()
#endif
#undef VM_GOTO_NEXT
#if HAVE_LABELS_AS_VALUES
#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 NEXT \
{ \
VM_PROGRAM_COUNTER_CHECK (); \
VM_NEXT_HOOK (); \
VM_GOTO_NEXT (); \
}
/* Just an abbreviation */
#define RETURN(X) { ac = (X); NEXT; }
Local Variables:
c-file-style: "gnu"
End:
*/

42
src/vm_expand.h
View file

@ -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:
*/

133
src/vm_loader.c Normal file
View file

@ -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:
*/

216
src/vm_number.c
View file

@ -41,9 +41,86 @@
/* This file is included in vm_engine.c */
/*
* Predicates
*/
#undef PRED
#define PRED(ctest,stest) \
{ \
ARGS1 (a1); \
if (SCM_INUMP (a1)) \
RETURN (SCM_BOOL (ctest)); \
RETURN (stest (a1)); \
}
VM_DEFINE_FUNCTION (zero, "zero?", 1)
{
PRED (SCM_INUM (a1) == 0, scm_zero_p);
}
/*
* Relational tests
*/
#undef REL
#define REL(crel,srel) \
{ \
ARGS2 (a1, a2); \
if (SCM_INUMP (a1) && SCM_INUMP (a2)) \
RETURN (SCM_BOOL (SCM_INUM (a1) crel SCM_INUM (a2))); \
RETURN (srel (a1, a2)); \
}
VM_DEFINE_FUNCTION (ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
VM_DEFINE_FUNCTION (lt, "lt?", 2)
{
REL (<, scm_less_p);
}
VM_DEFINE_FUNCTION (le, "le?", 2)
{
REL (<=, scm_leq_p);
}
VM_DEFINE_FUNCTION (gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
VM_DEFINE_FUNCTION (ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
/*
* 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) \
{ \
VM_SETUP_ARGS2 (); \
ARGS2 (a1, a2); \
if (SCM_INUMP (a1) && SCM_INUMP (a2)) \
{ \
int n = SCM_INUM (a1) CFUNC SCM_INUM (a2); \
@ -53,146 +130,39 @@
RETURN (SFUNC (a1, a2)); \
}
#define REL2(CREL,SREL) \
{ \
VM_SETUP_ARGS2 (); \
if (SCM_INUMP (a1) && SCM_INUMP (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 (neg, "neg", 1)
{
VM_SETUP_ARGS1 ();
if (SCM_INUMP (a1))
RETURN (SCM_BOOL (SCM_EQ_P (a1, SCM_INUM0)));
RETURN (scm_zero_p (a1));
FUNC1 (- SCM_INUM (a1), scm_difference (a1, SCM_UNDEFINED));
}
SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0)
VM_DEFINE_FUNCTION (inc, "inc", 1)
{
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)));
FUNC1 (SCM_INUM (a1) + 1, scm_sum (a1, SCM_MAKINUM (1)));
}
SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0)
VM_DEFINE_FUNCTION (dec, "dec", 1)
{
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)));
FUNC1 (SCM_INUM (a1) - 1, scm_difference (a1, SCM_MAKINUM (1)));
}
SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1)
{
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)
VM_DEFINE_FUNCTION (add, "add", 2)
{
FUNC2 (+, scm_sum);
}
SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1)
{
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)
VM_DEFINE_FUNCTION (sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0)
VM_DEFINE_FUNCTION (remainder, "remainder", 2)
{
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));
}
SCM_DEFINE_VM_FUNCTION (remainder, "remainder", "remainder", 2, 0)
{
VM_SETUP_ARGS2 ();
ARGS2 (a1, a2);
RETURN (scm_remainder (a1, a2));
}
SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0)
{
REL2 (<, scm_less_p);
}
SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0)
{
REL2 (>, scm_gr_p);
}
SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0)
{
REL2 (<=, scm_leq_p);
}
SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0)
{
REL2 (>=, scm_geq_p);
}
SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0)
{
REL2 (==, scm_num_eq_p);
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

143
src/vm_scheme.c
View file

@ -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 ();
RETURN (SCM_BOOL (SCM_NULLP (a1)));
}
SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0)
{
VM_SETUP_ARGS2 ();
CONS (ac, a1, a2);
NEXT;
}
SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1)
{
VM_SETUP_ARGSN ();
ac = SCM_EOL;
POP_LIST (nargs, ac);
NEXT;
}
SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0)
{
VM_SETUP_ARGS1 ();
SCM_VALIDATE_CONS (0, a1);
RETURN (SCM_CAR (a1));
}
SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0)
{
VM_SETUP_ARGS1 ();
SCM_VALIDATE_CONS (0, a1);
RETURN (SCM_CDR (a1));
}
SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0)
{
VM_SETUP_ARGS1 ();
ARGS1 (a1);
RETURN (SCM_BOOL (SCM_FALSEP (a1)));
}
SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1)
VM_DEFINE_FUNCTION (not_not, "not-not", 1)
{
VM_SETUP_ARGSN ();
ac = SCM_EOL;
POP_LIST (nargs, ac);
RETURN (scm_append (ac));
ARGS1 (a1);
RETURN (SCM_BOOL (!SCM_FALSEP (a1)));
}
SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1)
VM_DEFINE_FUNCTION (eq, "eq?", 2)
{
VM_SETUP_ARGSN ();
ac = SCM_EOL;
POP_LIST (nargs, ac);
RETURN (scm_append_x (ac));
ARGS2 (a1, a2);
RETURN (SCM_BOOL (SCM_EQ_P (a1, a2)));
}
SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0)
VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
{
VM_SETUP_ARGS3 ();
dynwinds = SCM_EOL;
ARGS2 (a1, a2);
RETURN (SCM_BOOL (!SCM_EQ_P (a1, a2)));
}
SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0)
VM_DEFINE_FUNCTION (nullp, "null?", 1)
{
SYNC (); /* must sync all registers */
PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */
nargs = 1; /* the number of arguments */
goto vm_call;
ARGS1 (a1);
RETURN (SCM_BOOL (SCM_NULLP (a1)));
}
VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (!SCM_NULLP (a1)));
}
VM_DEFINE_FUNCTION (pairp, "pair?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (SCM_CONSP (a1)));
}
VM_DEFINE_FUNCTION (listp, "list?", 1)
{
ARGS1 (a1);
RETURN (SCM_BOOL (scm_ilength (a1) >= 0));
}
VM_DEFINE_FUNCTION (cons, "cons", 2)
{
ARGS2 (a1, a2);
CONS (a1, a1, a2);
RETURN (a1);
}
VM_DEFINE_FUNCTION (car, "car", 1)
{
ARGS1 (a1);
SCM_VALIDATE_CONS (1, a1);
RETURN (SCM_CAR (a1));
}
VM_DEFINE_FUNCTION (cdr, "cdr", 1)
{
ARGS1 (a1);
SCM_VALIDATE_CONS (1, a1);
RETURN (SCM_CDR (a1));
}
VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
{
ARGS2 (a1, a2);
SCM_VALIDATE_CONS (1, a1);
SCM_SETCAR (a1, a2);
RETURN (SCM_UNSPECIFIED);
}
VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
{
ARGS2 (a1, a2);
SCM_VALIDATE_CONS (1, a1);
SCM_SETCDR (a1, a2);
RETURN (SCM_UNSPECIFIED);
}
VM_DEFINE_FUNCTION (list, "list", -1)
{
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:
*/

603
src/vm_system.c
View file

@ -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)
VM_DEFINE_INSTRUCTION (drop, "drop", 0)
{
SCM name = FETCH ();
if (SCM_NIMP (name))
scm_set_name_x (ac, name);
DROP ();
NEXT;
}
VM_DEFINE_INSTRUCTION (dup, "dup", 0)
{
PUSH (*sp);
NEXT;
}
/*
* %push family
* Object creation
*/
SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE)
VM_DEFINE_INSTRUCTION (void, "void", 0)
{
PUSH (ac);
PUSH (SCM_UNSPECIFIED);
NEXT;
}
SCM_DEFINE_INSTRUCTION (push_list, "%push-list", INST_SCM)
VM_DEFINE_INSTRUCTION (mark, "mark", 0)
{
SCM list;
for (list = FETCH (); SCM_NIMP (list); list = SCM_CDR (list))
PUSH (SCM_CAR (list));
PUSH (SCM_UNDEFINED);
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM)
VM_DEFINE_INSTRUCTION (make_true, "make-true", 0)
{
PUSH (FETCH ());
PUSH (SCM_BOOL_T);
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushl, "%pushl", INST_INUM)
VM_DEFINE_INSTRUCTION (make_false, "make-false", 0)
{
PUSH (LOCAL_VAR (SCM_INUM (FETCH ())));
PUSH (SCM_BOOL_F);
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushl_0, "%pushl:0", INST_NONE)
VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0)
{
PUSH (LOCAL_VAR (0));
PUSH (SCM_EOL);
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE)
VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1)
{
PUSH (LOCAL_VAR (1));
PUSH (SCM_MAKINUM ((signed char) FETCH ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT)
VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0)
{
SCM env;
SCM loc = FETCH ();
EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))));
PUSH (SCM_MAKINUM (0));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM)
VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0)
{
PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
PUSH (SCM_MAKINUM (1));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE)
VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
{
PUSH (EXTERNAL_VAR0 (0));
PUSH (SCM_MAKINUM ((signed short) FETCH2 ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE)
VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1)
{
PUSH (EXTERNAL_VAR0 (1));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM)
{
PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE)
{
PUSH (EXTERNAL_VAR1 (0));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE)
{
PUSH (EXTERNAL_VAR1 (1));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM)
{
PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
NEXT;
}
SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP)
{
ac = FETCH ();
VM_ASSERT_BOUND (ac);
PUSH (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);
}
#define OBJECT_REF(i) objects[i]
#define OBJECT_SET(i,o) objects[i] = o
SCM_DEFINE_INSTRUCTION (loadc, "%loadc", INST_SCM)
{
RETURN (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 (loadl, "%loadl", INST_INUM)
{
RETURN (LOCAL_VAR (SCM_INUM (FETCH ())));
}
#define VARIABLE_REF(v) SCM_CDR (v)
#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
SCM_DEFINE_INSTRUCTION (loadl_0, "%loadl:0", INST_NONE)
VM_DEFINE_INSTRUCTION (external, "external", 1)
{
RETURN (LOCAL_VAR (0));
}
SCM_DEFINE_INSTRUCTION (loadl_1, "%loadl:1", INST_NONE)
{
RETURN (LOCAL_VAR (1));
}
SCM_DEFINE_INSTRUCTION (loade, "%loade", INST_EXT)
{
SCM env;
SCM loc = FETCH ();
EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
RETURN (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))));
}
SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM)
{
RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
}
SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE)
{
RETURN (EXTERNAL_VAR0 (0));
}
SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE)
{
RETURN (EXTERNAL_VAR0 (1));
}
SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM)
{
RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
}
SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE)
{
RETURN (EXTERNAL_VAR1 (0));
}
SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE)
{
RETURN (EXTERNAL_VAR1 (1));
}
SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM)
{
RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
}
SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP)
{
ac = FETCH ();
VM_ASSERT_BOUND (ac);
RETURN (VM_VARIABLE_REF (ac));
}
/*
* %save family
*/
SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM)
{
LOCAL_VAR (SCM_INUM (FETCH ())) = ac;
int n = FETCH ();
while (n-- > 0)
CONS (external, SCM_UNDEFINED, external);
NEXT;
}
SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE)
/* ref */
VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1)
{
LOCAL_VAR (0) = ac;
PUSH (OBJECT_REF (FETCH ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE)
VM_DEFINE_INSTRUCTION (object_ref_2, "object-ref*2", 2)
{
LOCAL_VAR (1) = ac;
PUSH (OBJECT_REF (FETCH2 ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT)
VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1)
{
SCM env;
SCM loc = FETCH ();
EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac;
PUSH (LOCAL_REF (FETCH ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM)
VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0)
{
EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac;
PUSH (LOCAL_REF (0));
NEXT;
}
SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE)
VM_DEFINE_INSTRUCTION (local_ref_2, "local-ref*2", 2)
{
EXTERNAL_VAR0 (0) = ac;
PUSH (LOCAL_REF (FETCH2 ()));
NEXT;
}
SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE)
VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
{
EXTERNAL_VAR0 (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_1, "%savee:1", INST_INUM)
VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1)
{
EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = 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_1_0, "%savee:1:0", INST_NONE)
VM_DEFINE_INSTRUCTION (module_ref_2, "module-ref*2", 2)
{
EXTERNAL_VAR1 (0) = 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_1_1, "%savee:1:1", INST_NONE)
VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
{
EXTERNAL_VAR1 (1) = 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_2, "%savee:2", INST_INUM)
/* set */
VM_DEFINE_INSTRUCTION (local_set, "local-set", 1)
{
EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac;
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP)
VM_DEFINE_INSTRUCTION (local_set_2, "local-set*2", 2)
{
SCM cell = FETCH ();
VM_VARIABLE_SET (cell, ac);
LOCAL_SET (FETCH2 (), *sp);
DROP ();
NEXT;
}
VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
{
unsigned int i;
SCM e = external;
for (i = FETCH (); i; i--)
e = SCM_CDR (e);
SCM_SETCAR (e, *sp);
DROP ();
NEXT;
}
VM_DEFINE_INSTRUCTION (module_set, "module-set", 1)
{
int i = FETCH ();
SCM x = OBJECT_REF (i);
VARIABLE_SET (x, *sp);
DROP ();
NEXT;
}
VM_DEFINE_INSTRUCTION (module_set_2, "module-set*2", 2)
{
int i = FETCH2 ();
SCM x = OBJECT_REF (i);
VARIABLE_SET (x, *sp);
DROP ();
NEXT;
}
VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
{
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)
{
SCM addr = FETCH (); /* must always fetch */
if (!SCM_FALSEP (ac))
pc = SCM_VM_ADDRESS (addr);
NEXT;
#define BR(p) \
{ \
signed char offset = FETCH (); \
if (p) \
ip += offset; \
DROP (); \
NEXT; \
}
SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR)
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_null, "%br-if-null", INST_ADDR)
VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1)
{
SCM addr = FETCH (); /* must always fetch */
if (SCM_NULLP (ac))
{
ac = SCM_BOOL_T;
pc = SCM_VM_ADDRESS (addr);
}
NEXT;
BR (SCM_FALSEP (*sp));
}
SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-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_F;
pc = SCM_VM_ADDRESS (addr);
}
NEXT;
BR (SCM_EQ_P (sp[0], sp--[1]));
}
SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR)
VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1)
{
pc = SCM_VM_ADDRESS (*pc);
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));
}
VM_DEFINE_INSTRUCTION (jump, "jump", 1)
{
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 x;
POP (x);
nargs = FETCH ();
SCM_TICK; /* allow interrupt here */
nargs = SCM_INUM (FETCH ()); /* the number of arguments */
/*
* 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);
INIT_ARGS ();
/* Move arguments */
nreqs += restp;
while (nreqs-- > 0)
if (bp->nargs)
{
SCM obj;
POP (obj);
SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj;
int i;
SCM *base = fp + bp->nlocs;
for (i = 0; i < bp->nargs; i++)
base[i] = sp[i];
}
VM_FRAME_INIT_EXTERNAL_VARIABLES (fp, ac);
}
else
/* Proper tail call */
{
/* 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 ();
}
/* 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;
}
SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE)
VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1)
{
SCM *last_fp;
SYNC ();
PUSH (capture_vm_cont (vmp));
POP (program);
nargs = 1;
goto vm_call;
}
VM_DEFINE_INSTRUCTION (return, "return", 0)
{
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:
*/