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