From ac99cb0cb153b1691b48115f098a0008b78f9702 Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Sun, 22 Apr 2001 02:13:48 +0000 Subject: [PATCH] *** empty log message *** --- .cvsignore | 2 +- configure.in | 13 +- module/Makefile.am | 2 + module/language/.cvsignore | 3 + module/language/elisp/.cvsignore | 3 + module/language/ghil/.cvsignore | 3 + module/language/r5rs/.cvsignore | 3 + module/language/scheme/.cvsignore | 3 + module/language/scheme/translate.scm | 62 +-- module/system/.cvsignore | 3 + module/system/Makefile.am | 1 + module/system/base/.cvsignore | 2 + module/system/base/Makefile.am | 12 + module/system/base/compile.scm | 18 +- module/system/base/language.scm | 21 +- module/system/base/syntax.scm | 143 ++++-- module/system/il/.cvsignore | 2 + module/system/il/Makefile.am | 12 + module/system/il/compile.scm | 89 ++-- module/system/il/ghil.scm | 710 +++++++++++++-------------- module/system/il/glil.scm | 103 ++-- module/system/repl/.cvsignore | 2 + module/system/repl/Makefile.am | 12 + module/system/repl/command.scm | 12 +- module/system/repl/common.scm | 17 +- module/system/repl/repl.scm | 40 +- module/system/vm/.cvsignore | 2 + module/system/vm/Makefile.am | 12 + module/system/vm/assemble.scm | 191 ++++--- module/system/vm/backtrace.scm | 33 ++ module/system/vm/core.scm | 39 +- module/system/vm/disasm.scm | 3 +- module/system/vm/frame.scm | 125 +++++ module/system/vm/profile.scm | 2 +- module/system/vm/trace.scm | 47 +- src/Makefile.am | 8 +- src/frames.c | 184 +++++++ src/frames.h | 126 +++++ src/objcodes.c | 6 +- src/programs.c | 59 ++- src/programs.h | 13 +- src/vm.c | 144 +----- src/vm.h | 71 +-- src/vm_engine.c | 8 +- src/vm_engine.h | 2 +- src/vm_loader.c | 43 +- src/vm_system.c | 8 +- 47 files changed, 1442 insertions(+), 977 deletions(-) create mode 100644 module/language/.cvsignore create mode 100644 module/language/elisp/.cvsignore create mode 100644 module/language/ghil/.cvsignore create mode 100644 module/language/r5rs/.cvsignore create mode 100644 module/language/scheme/.cvsignore create mode 100644 module/system/.cvsignore create mode 100644 module/system/Makefile.am create mode 100644 module/system/base/Makefile.am create mode 100644 module/system/il/Makefile.am rewrite module/system/il/ghil.scm (70%) create mode 100644 module/system/repl/Makefile.am create mode 100644 module/system/vm/Makefile.am create mode 100644 module/system/vm/backtrace.scm create mode 100644 module/system/vm/frame.scm create mode 100644 src/frames.c create mode 100644 src/frames.h diff --git a/.cvsignore b/.cvsignore index d82fc9093..cd3b95162 100644 --- a/.cvsignore +++ b/.cvsignore @@ -1,7 +1,7 @@ -misc libtool config.* configure Makefile Makefile.in aclocal.m4 +misc diff --git a/configure.in b/configure.in index d82bb532e..ef35f5bf9 100644 --- a/configure.in +++ b/configure.in @@ -12,4 +12,15 @@ AC_PROG_LN_S AM_PROG_LIBTOOL AC_C_LABELS_AS_VALUES -AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile) +guiledir="\$(datadir)/guile" +AC_SUBST(guiledir) + +GUILEC="GUILE_LOAD_PATH=\$(top_srcdir)/module \ + LD_LIBRARY_PATH=\$(top_srcdir)/src/.libs \ + guile -s \$(top_srcdir)/src/guilec" +AC_SUBST(GUILEC) + +AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile + module/system/Makefile module/system/base/Makefile + module/system/vm/Makefile module/system/il/Makefile + module/system/repl/Makefile) diff --git a/module/Makefile.am b/module/Makefile.am index 4c26fc3e2..006ba0c4b 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,3 +1,5 @@ +SUBDIRS = system + DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~ diff --git a/module/language/.cvsignore b/module/language/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/elisp/.cvsignore b/module/language/elisp/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/elisp/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/ghil/.cvsignore b/module/language/ghil/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/ghil/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/r5rs/.cvsignore b/module/language/r5rs/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/r5rs/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/scheme/.cvsignore b/module/language/scheme/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/language/scheme/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 7ba07b34b..b4fb5e397 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -29,7 +29,7 @@ (define (translate x e) (call-with-ghil-environment (make-ghil-mod e) '() (lambda (env vars) - (make- env #f vars 0 (trans env #f x))))) + ( env #f vars #f (trans env #f x))))) ;;; @@ -43,28 +43,28 @@ (cond ((pair? x) (let ((y (macroexpand x))) (if (eq? x y) - (trans-pair e (or (location x) l) (car x) (cdr x)) - (trans e l y)))) + (trans-pair e (or (location x) l) (car x) (cdr x)) + (trans e l y)))) ((symbol? x) - (let ((y (expand-symbol x))) - (if (eq? x y) - (make- e l (ghil-lookup e x)) - (trans e l y)))) - (else (make- e l x)))) + (let ((y (symbol-expand x))) + (if (symbol? y) + ( e l (ghil-lookup e y)) + (trans e l y)))) + (else ( e l x)))) -(define (expand-symbol x) +(define (symbol-expand 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))))) + (let ((sym (string->symbol (substring s (1+ i))))) + `(slot ,(loop (substring s 0 i)) (quote ,sym))) + (string->symbol s))))) (define (trans-pair e l head tail) (define (trans:x x) (trans e l x)) (define (trans:pair x) (trans-pair e l (car x) (cdr x))) (define (trans:body body) (trans-body e l body)) - (define (make:void) (make- e l)) + (define (make:void) ( e l)) (define (bad-syntax) (syntax-error l (format #f "bad ~A" head) (cons head tail))) (case head @@ -77,26 +77,26 @@ ;; (quote OBJ) ((quote) (match tail - ((obj) (make- e l obj)) + ((obj) ( e l obj)) (else (bad-syntax)))) ;; (quasiquote OBJ) ((quasiquote) (match tail - ((obj) (make- e l (trans-quasiquote e l obj))) + ((obj) ( e l (trans-quasiquote e l obj))) (else (bad-syntax)))) ((define define-private) (match tail ;; (define NAME VAL) (((? symbol? name) val) - (make- e l (ghil-lookup e name) (trans:x val))) + ( e l (ghil-lookup e name) (trans:x val))) ;; (define (NAME FORMALS...) BODY...) ((((? symbol? name) . formals) . body) ;; -> (define NAME (lambda FORMALS BODY...)) (let ((val (trans:x `(lambda ,formals ,@body)))) - (make- e l (ghil-lookup e name) val))) + ( e l (ghil-lookup e name) val))) (else (bad-syntax)))) @@ -104,7 +104,7 @@ (match tail ;; (set! NAME VAL) (((? symbol? name) val) - (make- e l (ghil-lookup e name) (trans:x val))) + ( e l (ghil-lookup e name) (trans:x val))) ;; (set! (NAME ARGS...) VAL) ((((? symbol? name) . args) val) @@ -117,22 +117,22 @@ ((if) (match tail ((test then) - (make- e l (trans:x test) (trans:x then) (make:void))) + ( e l (trans:x test) (trans:x then) (make:void))) ((test then else) - (make- e l (trans:x test) (trans:x then) (trans:x else))) + ( e l (trans:x test) (trans:x then) (trans:x else))) (else (bad-syntax)))) ;; (and EXPS...) ((and) - (make- e l (map trans:x tail))) + ( e l (map trans:x tail))) ;; (or EXPS...) ((or) - (make- e l (map trans:x tail))) + ( e l (map trans:x tail))) ;; (begin EXPS...) ((begin) - (make- e l (map trans:x tail))) + ( e l (map trans:x tail))) ((let) (match tail @@ -144,14 +144,14 @@ ;; (let () BODY...) ((() body ...) ;; NOTE: This differs from `begin' - (make- e l (list (trans:body body)))) + ( e l (list (trans:body body)))) ;; (let ((SYM VAL) ...) BODY...) (((((? symbol? sym) val) ...) body ...) (let ((vals (map trans:x val))) (call-with-ghil-bindings e sym (lambda (vars) - (make- e l vars vals (trans:body body)))))) + ( e l vars vals (trans:body body)))))) (else (bad-syntax)))) @@ -171,7 +171,7 @@ (call-with-ghil-bindings e sym (lambda (vars) (let ((vals (map trans:x val))) - (make- e l vars vals (trans:body body)))))) + ( e l vars vals (trans:body body)))))) (else (bad-syntax)))) ;; (cond (CLAUSE BODY...) ...) @@ -222,7 +222,7 @@ (receive (syms rest) (parse-formals formals) (call-with-ghil-environment e syms (lambda (env vars) - (make- env l vars rest (trans-body env l body)))))) + ( env l vars rest (trans-body env l body)))))) (else (bad-syntax)))) ((eval-case) @@ -240,8 +240,8 @@ (else (if (memq head scheme-primitives) - (make- e l head (map trans:x tail)) - (make- e l (trans:x head) (map trans:x tail)))))) + ( e l head (map trans:x tail)) + ( e l (trans:x head) (map trans:x tail)))))) (define (trans-quasiquote e l x) (cond ((not (pair? x)) x) @@ -250,8 +250,8 @@ (match (cdr x) ((obj) (if (eq? (car x) 'unquote) - (make- e l (trans e l obj)) - (make- e l (trans e l obj)))) + ( e l (trans e l obj)) + ( e l (trans e l obj)))) (else (syntax-error l (format #f "bad ~A" (car x)) x))))) (else (cons (trans-quasiquote e l (car x)) (trans-quasiquote e l (cdr x)))))) diff --git a/module/system/.cvsignore b/module/system/.cvsignore new file mode 100644 index 000000000..1cd7f2514 --- /dev/null +++ b/module/system/.cvsignore @@ -0,0 +1,3 @@ +Makefile +Makefile.in +*.go diff --git a/module/system/Makefile.am b/module/system/Makefile.am new file mode 100644 index 000000000..442c5cc40 --- /dev/null +++ b/module/system/Makefile.am @@ -0,0 +1 @@ +SUBDIRS = vm diff --git a/module/system/base/.cvsignore b/module/system/base/.cvsignore index e796b66a8..1cd7f2514 100644 --- a/module/system/base/.cvsignore +++ b/module/system/base/.cvsignore @@ -1 +1,3 @@ +Makefile +Makefile.in *.go diff --git a/module/system/base/Makefile.am b/module/system/base/Makefile.am new file mode 100644 index 000000000..e4dff01ce --- /dev/null +++ b/module/system/base/Makefile.am @@ -0,0 +1,12 @@ +SOURCES = syntax.scm language.scm compile.scm +OBJECTS = syntax.go language.go compile.go + +vmdir = $(guiledir)/system/vm +vm_DATA = $(SOURCES) $(OBJECTS) + +DISTCLEANFILES = $(OBJECTS) +MAINTAINERCLEANFILES = Makefile.in + +SUFFIXES = .scm .go +.scm.go: + $(GUILEC) $< diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index adc7e2d90..3da36a7d1 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -20,10 +20,10 @@ ;;; Code: (define-module (system base compile) - :use-module (oop goops) :use-syntax (system base syntax) :use-module (system base language) :use-module (system il compile) + :use-module (system il glil) :use-module (system vm core) :use-module (system vm assemble) :use-module (ice-9 regex)) @@ -32,20 +32,18 @@ ;;; Compiler environment ;;; -(define-vm-class () - vm language module optimize) +(define-record ( vm language module)) (define-public (make-cenv . rest) - (apply make rest)) + (apply rest)) (define-public (syntax-error loc msg exp) (throw 'syntax-error loc msg exp)) (define-public (call-with-compile-error-catch thunk) - (catch 'syntax-error - thunk - (lambda (key loc msg exp) - (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) + (try (thunk) + ((syntax-error loc msg exp) + (format #t "~A:~A: ~A: ~A" (car loc) (cdr loc) msg exp)))) ;;; @@ -65,7 +63,9 @@ (let* ((source (read-file-in file scheme)) (objcode (apply compile-in source (current-module) scheme opts))) - (uniform-array-write (objcode->string objcode) port)))) + (if (memq :c opts) + (pprint-glil objcode port) + (uniform-array-write (objcode->string objcode) port))))) (format #t "Wrote ~A\n" comp)))) (lambda (key . args) (format #t "ERROR: During compiling ~A:\n" file) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 5ac1eb3ee..9831b51da 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -20,7 +20,6 @@ ;;; Code: (define-module (system base language) - :use-module (oop goops) :use-syntax (system base syntax) :export (define-language lookup-language)) @@ -29,21 +28,15 @@ ;;; Language class ;;; -(define-vm-class () - name title version environment - reader printer read-file - (expander (lambda (x e) x)) - (translator (lambda (x e) x)) - (evaluator #f) - ) - -(define-method (write (lang ) port) - (display "#")) +(define-record ( name title version reader printer read-file + (expander (lambda (x e) x)) + (translator (lambda (x e) x)) + (evaluator #f) + (environment #f) + )) (define-macro (define-language name . spec) - `(define ,name (,make , :name ',name ,@spec))) + `(define ,name (, :name ',name ,@spec))) (define (lookup-language name) (let ((m (resolve-module `(language ,name spec)))) diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index f14b924b7..0526b3536 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,34 +1,34 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; 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. -;; +;; 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. -;; +;; 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. +;; Boston, MA 02111-1307, USA ;;; Code: (define-module (system base syntax) - :use-module (oop goops) + :use-module (ice-9 try) :use-module (ice-9 match) :use-module (ice-9 receive) :use-module (ice-9 and-let-star) - :export (match syntax-error and-let* receive)) + :export (try stack-catch match syntax-error receive and-let*)) ;;; -;;; Keywords by `:KEYWORD' +;;; Keywords by `:KEYWORD ;;; (read-set! keywords 'prefix) @@ -41,9 +41,9 @@ ;; FOO.BAR -> (slot FOO 'BAR) (define (expand-dot! x) - (cond ((and (symbol? x) (not (eq? x '...))) (expand-symbol x)) + (cond ((symbol? x) (expand-symbol x)) ((pair? x) - (cond ((memq (car x) '(quote quasiquote)) x) + (cond ((eq? (car x) 'quote) x) (else (set-car! x (expand-dot! (car x))) (set-cdr! x (expand-dot! (cdr x))) x))) @@ -57,39 +57,110 @@ (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) +(define syntax expand-dot!) ;;; -;;; Simplified define-class +;;; Type +;;; + +(export-syntax define-type) +(define-macro (define-type name sig) sig) + +;;; +;;; Record +;;; + +(export-syntax define-record) +(define-macro (define-record def) + (let ((name (car def)) (slots (cdr def))) + `(begin + (define (,name . args) + (vector ',name (%make-struct + args + (list ,@(map (lambda (slot) + (if (pair? slot) + `(cons ',(car slot) ,(cadr slot)) + `',slot)) + slots))))) + (define (,(symbol-append name '?) x) + (and (vector? x) (eq? (vector-ref x 0) ',name))) + ,@(do ((n 1 (1+ n)) + (slots (cdr def) (cdr slots)) + (ls '() (cons (let* ((slot (car slots)) + (slot (if (pair? slot) (car slot) slot))) + `(define ,(string->symbol + (format #f "~A-~A" name n)) + (lambda (x) (slot x ',slot)))) + ls))) + ((null? slots) (reverse! ls)))))) + +(define *unbound* "#") + +(define-public (%make-struct args slots) + (map (lambda (slot) + (let* ((key (if (pair? slot) (car slot) slot)) + (def (if (pair? slot) (cdr slot) *unbound*)) + (val (get-key args (symbol->keyword key) def))) + (if (eq? val *unbound*) + (error "Slot unbound:" key) + (cons key val)))) + slots)) + +(define (get-key klist key def) + (do ((ls klist (cddr ls))) + ((or (null? ls) (eq? (car ls) key)) + (if (null? ls) def (cadr ls))))) + +(define-public slot + (make-procedure-with-setter + (lambda (struct name) + (let ((data (assq name (vector-ref struct 1)))) + (cond ((not data) + (error "Unknown slot:" name)) + (else (cdr data))))) + (lambda (struct name val) + (let ((data (assq name (vector-ref struct 1)))) + (cond ((not data) + (error "Unknown slot:" name)) + (else (set-cdr! data val))))))) + +;;; +;;; Variants ;;; -;; (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) +(export-syntax |) +(define-macro (| . rest) + `(begin ,@(map %make-variant-type rest))) + +(define (%make-variant-type def) + (let ((name (car def)) (slots (cdr def))) + `(begin + (define ,def (vector ',name ,@slots)) + (define (,(symbol-append name '?) x) + (and (vector? x) (eq? (vector-ref x 0) ',name))) + ,@(do ((n 1 (1+ n)) + (slots slots (cdr slots)) + (ls '() (cons `(define ,(string->symbol + (format #f "~A-~A" name n)) + ,(string->symbol (format #f "%slot-~A" n))) + ls))) + ((null? slots) (reverse! ls)))))) + +(define-public (%slot-1 x) (vector-ref x 1)) +(define-public (%slot-2 x) (vector-ref x 2)) +(define-public (%slot-3 x) (vector-ref x 3)) +(define-public (%slot-4 x) (vector-ref x 4)) +(define-public (%slot-5 x) (vector-ref x 5)) +(define-public (%slot-6 x) (vector-ref x 6)) +(define-public (%slot-7 x) (vector-ref x 7)) +(define-public (%slot-8 x) (vector-ref x 8)) +(define-public (%slot-9 x) (vector-ref x 9)) + ;;; -;;; Other utilities +;;; Utilities ;;; (define-public (list-fold f d l) diff --git a/module/system/il/.cvsignore b/module/system/il/.cvsignore index e796b66a8..1cd7f2514 100644 --- a/module/system/il/.cvsignore +++ b/module/system/il/.cvsignore @@ -1 +1,3 @@ +Makefile +Makefile.in *.go diff --git a/module/system/il/Makefile.am b/module/system/il/Makefile.am new file mode 100644 index 000000000..d1e749bc1 --- /dev/null +++ b/module/system/il/Makefile.am @@ -0,0 +1,12 @@ +SOURCES = glil.scm ghil.scm macros.scm compile.scm +OBJECTS = glil.go ghil.go macros.go compile.go + +vmdir = $(guiledir)/system/il +vm_DATA = $(SOURCES) $(OBJECTS) + +DISTCLEANFILES = $(OBJECTS) +MAINTAINERCLEANFILES = Makefile.in + +SUFFIXES = .scm .go +.scm.go: + $(GUILEC) $< diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index e9354c45b..8e6210f16 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -20,7 +20,6 @@ ;;; Code: (define-module (system il compile) - :use-module (oop goops) :use-syntax (system base syntax) :use-module (system il glil) :use-module (system il ghil) @@ -40,22 +39,22 @@ (define (optimize x) (match x (($ env var val) - (make- env var (optimize val))) + ( env var (optimize val))) (($ test then else) - (make- (optimize test) (optimize then) (optimize else))) + ( (optimize test) (optimize then) (optimize else))) (($ exps) - (make- (map optimize exps))) + ( (map optimize exps))) (($ env vars vals body) - (make- env vars (map optimize vals) (optimize body))) + ( env vars (map optimize vals) (optimize body))) (($ env vars rest body) - (make- env vars rest (optimize body))) + ( env vars rest (optimize body))) (($ inst args) - (make- inst (map optimize args))) + ( inst (map optimize args))) (($ env proc args) (match proc @@ -67,9 +66,9 @@ (set! v.env env) (ghil-env-add! env v)) lambda-env.variables) - (optimize (make- env vars args body))) + (optimize ( env vars args body))) (else - (make- env (optimize proc) (map optimize args))))) + ( env (optimize proc) (map optimize args))))) (else x))) @@ -77,25 +76,25 @@ ;;; Stage 3: Code generation ;;; -(define *ia-void* (make-)) -(define *ia-drop* (make- 'drop 0)) -(define *ia-return* (make- 'return 0)) +(define *ia-void* ()) +(define *ia-drop* ( 'drop 0)) +(define *ia-return* ( 'return 0)) (define (make-label) (gensym ":L")) (define (make-glil-var op env var) (case var.kind ((argument) - (make- op var.index)) + ( op var.index)) ((local) - (make- op var.index)) + ( op var.index)) ((external) (do ((depth 0 (1+ depth)) (e env e.parent)) ((eq? e var.env) - (make- op depth var.index)))) + ( op depth var.index)))) ((module) - (make- op var.env var.name)) + ( op var.env var.name)) (else (error "Unknown kind of variable:" var)))) (define (codegen ghil) @@ -104,12 +103,13 @@ (set! stack (cons code stack))) (define (comp tree tail drop) (define (push-label! label) - (push-code! (make- label))) + (push-code! ( label))) (define (push-branch! inst label) - (push-code! (make- inst label))) - (define (push-call! inst args) + (push-code! ( inst label))) + (define (push-call! loc inst args) (for-each comp-push args) - (push-code! (make- inst (length args)))) + (push-code! ( inst (length args))) + (push-code! ( loc))) ;; possible tail position (define (comp-tail tree) (comp tree tail drop)) ;; push the result @@ -131,7 +131,7 @@ (return-code! *ia-void*)) ;; return object if necessary (define (return-object! obj) - (return-code! (make- obj))) + (return-code! ( obj))) ;; ;; dispatch (match tree @@ -145,28 +145,32 @@ (let loop ((x exp)) (match x ((? list? ls) - (push-call! 'mark '()) + (push-call! #f 'mark '()) (for-each loop ls) - (push-call! 'list-mark '())) + (push-call! #f 'list-mark '())) ((? pair? pp) (loop (car pp)) (loop (cdr pp)) - (push-code! (make- 'cons 2))) + (push-code! ( 'cons 2))) (($ env loc exp) (comp-push exp)) (($ env loc exp) (comp-push exp) - (push-call! 'list-break '())) + (push-call! #f 'list-break '())) (else - (push-code! (make- x))))) + (push-code! ( x))))) (maybe-drop) (maybe-return)) (($ env loc var) (return-code! (make-glil-var 'ref env var))) - ((or ($ env loc var val) - ($ env loc var val)) + (($ env loc var val) + (comp-push val) + (push-code! (make-glil-var 'set env var)) + (return-void!)) + + (($ env loc var val) (comp-push val) (push-code! (make-glil-var 'set env var)) (return-void!)) @@ -228,9 +232,9 @@ (maybe-drop) (maybe-return)) (comp-push (car exps)) - (push-call! 'dup '()) + (push-call! #f 'dup '()) (push-branch! 'br-if L1) - (push-call! 'drop '()))))) + (push-call! #f 'drop '()))))) (($ env loc exps) ;; EXPS... @@ -249,7 +253,10 @@ (for-each comp-push vals) (for-each (lambda (var) (push-code! (make-glil-var 'set env var))) (reverse vars)) - (comp-tail body)) + (let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars))) + (if (not (null? vars)) (push-code! ( vars)))) + (comp-tail body) + (push-code! ())) (($ env loc vars rest body) (return-code! (codegen tree))) @@ -257,7 +264,7 @@ (($ env loc inst args) ;; ARGS... ;; (INST NARGS) - (push-call! inst args) + (push-call! loc inst args) (maybe-drop) (maybe-return)) @@ -266,7 +273,7 @@ ;; ARGS... ;; ([tail-]call NARGS) (comp-push proc) - (push-call! (if tail 'tail-call 'call) args) + (push-call! loc (if tail 'tail-call 'call) args) (maybe-drop)))) ;; ;; main @@ -279,19 +286,25 @@ (finalize-index! args) (finalize-index! locs) (finalize-index! exts) + ;; meta bindings + (let ((vars (map (lambda (v) (list v.name v.kind v.index)) args))) + (if (not (null? vars)) (push-code! ( vars)))) ;; 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)))))) + (cond ((eq? v.kind 'external) + (push-code! ( 'ref n)) + (push-code! ( '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))))))) + (let ((vars ( :nargs (length args) + :nrest (if rest 1 0) + :nlocs (length locs) + :nexts (length exts)))) + ( vars (reverse! stack)))))))) (define (finalize-index! list) (do ((n 0 (1+ n)) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm dissimilarity index 70% index eb356a556..ea3d66e4e 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -1,365 +1,345 @@ -;;; 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 (ice-9 match) - :use-module (ice-9 regex) - :export - (parse-ghil - ghil-lookup ghil-primitive? - make- ? -1 -2 - make- ? -1 -2 -3 - make- ? - -1 -2 -3 - make- ? - -1 -2 -3 - make- ? - -1 -2 - -3 - - make- ? - -1 -2 -3 - make- ? - -1 -2 -3 -4 - make- ? - -1 -2 -3 -4 - - make- ? - -1 -2 -3 -4 -5 - make- ? -1 -2 -3 - make- ? -1 -2 -3 - make- ? -1 -2 -3 - make- ? - -1 -2 -3 -4 -5 - make- ? -1 -2 - -3 -4 -5 - make- ? - -1 -2 -3 -4 - make- ? - -1 -2 -3 -4 - )) - - -;;; -;;; Parse tree -;;; - -(define-structure ( env loc)) -(define-structure ( env loc obj)) -(define-structure ( env loc exp)) -(define-structure ( env loc exp)) -(define-structure ( env loc exp)) - -(define-structure ( env loc var)) -(define-structure ( env loc var val)) -(define-structure ( env loc var val)) - -(define-structure ( env loc test then else)) -(define-structure ( env loc exps)) -(define-structure ( env loc exps)) -(define-structure ( env loc exps)) -(define-structure ( env loc vars vals body)) -(define-structure ( env loc vars rest body)) -(define-structure ( env loc proc args)) -(define-structure ( env loc inline args)) - -(define-public (ghil-env ghil) (vector-ref ghil 1)) -(define-public (ghil-loc ghil) (vector-ref ghil 2)) - - -;;; -;;; Procedures -;;; - -(define *core-primitives* - '(@void @quote @define @set! @if @begin @let @letrec @lambda)) - -(define *macro-module* (resolve-module '(system il macros))) - -(define (ghil-primitive-macro? x) - (and (module-defined? *macro-module* x) - (procedure? (module-ref *macro-module* x)))) - -(define (ghil-macro-expander x) - (module-ref *macro-module* x)) - -(define (ghil-primitive? x) - (or (memq x *core-primitives*) - (ghil-primitive-macro? x))) - - -;;; -;;; Variables -;;; - -(define-vm-class () - env name kind type value index) - -(define-public (make-ghil-var env name kind) - (make :env env :name name :kind kind)) - -(define-method (write (var ) port) - (display "#" port)) - - -;;; -;;; Modules -;;; - -(define-vm-class () - (module) - (table '()) - (imports '())) - -(define-public (make-ghil-mod module) - (make :module module)) - -(define-method (write (mod ) port) - (display "#" port)) - -(define-method (ghil-lookup (mod ) (sym )) - (or (assq-ref mod.table sym) - ;; (let ((var (make-ghil-var (env-identifier mod.module) sym 'module))) - (let ((var (make-ghil-var #f sym 'module))) - (set! mod.table (acons sym var mod.table)) - var))) - - -;;; -;;; Environments -;;; - -(define-vm-class () - (mod) - (parent #f) - (table '()) - (variables '())) - -(export make-ghil-env) -(define-method (make-ghil-env (m )) - (make :mod m :parent m)) - -(define-method (make-ghil-env (e )) - (make :mod e.mod :parent e)) - -(define (ghil-env-toplevel? e) - (eq? e.mod e.parent)) - -(define-method (ghil-env-ref (env ) (sym )) - (assq-ref env.table sym)) - -(export ghil-env-add!) -(define-method (ghil-env-add! (env ) (var )) - (set! env.table (acons var.name var env.table)) - (set! env.variables (cons var env.variables))) - -(define-method (ghil-env-remove! (env ) (var )) - (set! env.table (assq-remove! env.table var.name))) - -(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)))))) - -(define-public (call-with-ghil-environment e syms func) - (let* ((e (make-ghil-env e)) - (vars (map (lambda (s) - (let ((v (make-ghil-var e s 'argument))) - (ghil-env-add! e v) v)) - syms))) - (func e vars))) - -(define-public (call-with-ghil-bindings e syms func) - (let* ((vars (map (lambda (s) - (let ((v (make-ghil-var e s 'local))) - (ghil-env-add! e v) v)) - syms)) - (ret (func vars))) - (for-each (lambda (v) (ghil-env-remove! e v)) vars) - ret)) - - -;;; -;;; 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 (parse-pair x e) - (let ((head (car x)) (tail (cdr x))) - (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) - (if (ghil-primitive-macro? head) - (parse (apply (ghil-macro-expander head) tail) e) - (parse-primitive head tail e)) - (make- e (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)))))) - - ;; (@@ OP ARGS...) - ((@@) - (match args - ((op . args) - (make- op (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) - (let ((v (make-ghil-var e s 'local))) - (ghil-env-add! e v) v)) - sym)) - (body (parse-body body e))) - (for-each (lambda (v) (ghil-env-remove! e v)) vars) - (make- e vars vals body))))) - - ;; (@letrec ((SYM INIT)...) BODY...) - ((@letrec) - (match args - ((((sym init) ...) body ...) - (let* ((vars (map (lambda (s) - (let ((v (make-ghil-var e s 'local))) - (ghil-env-add! e v) v)) - sym)) - (vals (map-parse init e)) - (body (parse-body body e))) - (for-each (lambda (v) (ghil-env-remove! e v)) vars) - (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)) - (vars (map (lambda (s) - (let ((v (make-ghil-var e s 'argument))) - (ghil-env-add! e v) v)) - syms))) - (make- e vars rest (parse-body body e))))))) - - ;; (@eval-case CLAUSE...) - ((@eval-case) - (let loop ((clauses args)) - (cond ((null? clauses) (make-)) - ((or (eq? (caar clauses) '@else) - (and (memq 'load-toplevel (caar clauses)) - (ghil-env-toplevel? e))) - (parse-body (cdar clauses) e)) - (else - (loop (cdr clauses)))))) - - (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)))) +;;; 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-syntax (system base syntax) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :export + ( + ? -1 -2 + ? -1 -2 -3 + ? + -1 -2 -3 + ? + -1 -2 -3 + ? + -1 -2 + -3 + + ? -1 -2 -3 + ? -1 -2 -3 -4 + ? + -1 -2 -3 -4 + + ? + -1 -2 -3 -4 -5 + ? -1 -2 -3 + ? -1 -2 -3 + ? -1 -2 -3 + ? + -1 -2 -3 -4 -5 + ? -1 -2 + -3 -4 -5 + ? + -1 -2 -3 -4 + ? + -1 -2 -3 -4 + )) + + +;;; +;;; Parse tree +;;; + +(define-type + (| + ;; Objects + ( env loc) + ( env loc obj) + ( env loc exp) + ( env loc exp) + ( env loc exp) + ;; Variables + ( env loc var) + ( env loc var val) + ( env loc var val) + ;; Controls + ( env loc test then else) + ( env loc exps) + ( env loc exps) + ( env loc exps) + ( env loc vars vals body) + ( env loc vars rest body) + ( env loc proc args) + ( env loc inline args))) + +(define-public ghil-env %slot-1) +(define-public ghil-loc %slot-2) + + +;;; +;;; Procedures +;;; + +(define *core-primitives* + '(@void @quote @define @set! @if @begin @let @letrec @lambda)) + +(define *macro-module* (resolve-module '(system il macros))) + +(define-public (ghil-primitive-macro? x) + (and (module-defined? *macro-module* x) + (procedure? (module-ref *macro-module* x)))) + +(define (ghil-macro-expander x) + (module-ref *macro-module* x)) + +(define (ghil-primitive? x) + (or (memq x *core-primitives*) + (ghil-primitive-macro? x))) + + +;;; +;;; Variables +;;; + +(define-record ( env name kind (type #f) (value #f) (index #f))) + +(define-public (make-ghil-var env name kind) + ( :env env :name name :kind kind)) + + +;;; +;;; Modules +;;; + +(define-record ( module (table '()) (imports '()))) + +(define-public (make-ghil-mod module) + ( :module module)) + + +;;; +;;; Environments +;;; + +(define-record ( mod parent (table '()) (variables '()))) + +(define-public (make-ghil-env e) + (match e + (($ ) ( :mod e :parent e)) + (($ m) ( :mod m :parent e)))) + +(define (ghil-env-toplevel? e) + (eq? e.mod e.parent)) + +(define (ghil-env-ref env sym) + (assq-ref env.table sym)) + +(define-public (ghil-env-add! env var) + (set! env.table (acons var.name var env.table)) + (set! env.variables (cons var env.variables))) + +(define (ghil-env-remove! env var) + (set! env.table (assq-remove! env.table var.name))) + + +;;; +;;; Public interface +;;; + +(define-public (ghil-lookup env sym) + (or (ghil-env-ref env sym) + (let loop ((e env.parent)) + (cond ((? e) + (or (assq-ref e.table sym) + (let ((var (make-ghil-var #f sym 'module))) + (set! e.table (acons sym var e.table)) + var))) + ((ghil-env-ref e sym) => + (lambda (var) (set! var.kind 'external) var)) + (else (loop e.parent)))))) + +(define-public (call-with-ghil-environment e syms func) + (let* ((e (make-ghil-env e)) + (vars (map (lambda (s) + (let ((v (make-ghil-var e s 'argument))) + (ghil-env-add! e v) v)) + syms))) + (func e vars))) + +(define-public (call-with-ghil-bindings e syms func) + (let* ((vars (map (lambda (s) + (let ((v (make-ghil-var e s 'local))) + (ghil-env-add! e v) v)) + syms)) + (ret (func vars))) + (for-each (lambda (v) (ghil-env-remove! e v)) vars) + ret)) + + +;;; +;;; Parser +;;; + +;;; (define-public (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)))) +;;; ( (symbol->keyword sym)))) +;;; (else ( e (ghil-lookup e x)))))) +;;; (else ( x)))) +;;; +;;; (define (map-parse x e) +;;; (map (lambda (x) (parse x e)) x)) +;;; +;;; (define (parse-pair x e) +;;; (let ((head (car x)) (tail (cdr x))) +;;; (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@)) +;;; (if (ghil-primitive-macro? head) +;;; (parse (apply (ghil-macro-expander head) tail) e) +;;; (parse-primitive head tail e)) +;;; ( e (parse head e) (map-parse tail e))))) +;;; +;;; (define (parse-primitive prim args e) +;;; (case prim +;;; ;; (@ IDENTIFIER) +;;; ((@) +;;; (match args +;;; (() +;;; ( e (make-ghil-var '@ '@ 'module))) +;;; ((identifier) +;;; (receive (module name) (identifier-split identifier) +;;; ( e (make-ghil-var module name 'module)))))) +;;; +;;; ;; (@@ OP ARGS...) +;;; ((@@) +;;; (match args +;;; ((op . args) +;;; ( op (map-parse args e))))) +;;; +;;; ;; (@void) +;;; ((@void) +;;; (match args +;;; (() ()))) +;;; +;;; ;; (@quote OBJ) +;;; ((@quote) +;;; (match args +;;; ((obj) +;;; ( obj)))) +;;; +;;; ;; (@define NAME VAL) +;;; ((@define) +;;; (match args +;;; ((name val) +;;; (let ((v (ghil-lookup e name))) +;;; ( e v (parse val e)))))) +;;; +;;; ;; (@set! NAME VAL) +;;; ((@set!) +;;; (match args +;;; ((name val) +;;; (let ((v (ghil-lookup e name))) +;;; ( e v (parse val e)))))) +;;; +;;; ;; (@if TEST THEN [ELSE]) +;;; ((@if) +;;; (match args +;;; ((test then) +;;; ( (parse test e) (parse then e) ())) +;;; ((test then else) +;;; ( (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) +;;; (let ((v (make-ghil-var e s 'local))) +;;; (ghil-env-add! e v) v)) +;;; sym)) +;;; (body (parse-body body e))) +;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) +;;; ( e vars vals body))))) +;;; +;;; ;; (@letrec ((SYM INIT)...) BODY...) +;;; ((@letrec) +;;; (match args +;;; ((((sym init) ...) body ...) +;;; (let* ((vars (map (lambda (s) +;;; (let ((v (make-ghil-var e s 'local))) +;;; (ghil-env-add! e v) v)) +;;; sym)) +;;; (vals (map-parse init e)) +;;; (body (parse-body body e))) +;;; (for-each (lambda (v) (ghil-env-remove! e v)) vars) +;;; ( e vars vals body))))) +;;; +;;; ;; (@lambda FORMALS BODY...) +;;; ((@lambda) +;;; (match args +;;; ((formals . body) +;;; (receive (syms rest) (parse-formals formals) +;;; (let* ((e (make-ghil-env e)) +;;; (vars (map (lambda (s) +;;; (let ((v (make-ghil-var e s 'argument))) +;;; (ghil-env-add! e v) v)) +;;; syms))) +;;; ( e vars rest (parse-body body e))))))) +;;; +;;; ;; (@eval-case CLAUSE...) +;;; ((@eval-case) +;;; (let loop ((clauses args)) +;;; (cond ((null? clauses) ()) +;;; ((or (eq? (caar clauses) '@else) +;;; (and (memq 'load-toplevel (caar clauses)) +;;; (ghil-env-toplevel? e))) +;;; (parse-body (cdar clauses) e)) +;;; (else +;;; (loop (cdr clauses)))))) +;;; +;;; (else (error "Unknown primitive:" prim)))) +;;; +;;; (define (parse-body x e) +;;; ( (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 index cd2865fff..f4a5c560d 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -20,54 +20,59 @@ ;;; Code: (define-module (system il glil) + :use-syntax (system base syntax) :use-module (ice-9 match) :export (pprint-glil - make- ? + + ? -1 -2 -3 -4 -5 - make- ? -1 -2 + ? -1 + ? + ? -1 -2 - make- ? - make- ? -1 + ? + ? -1 - make- ? -1 -2 - make- ? -1 -2 - make- ? + ? -1 -2 + ? -1 -2 + ? -1 -2 -3 - make- ? + ? -1 -2 -3 - make- ? -1 - make- ? -1 -2 - make- ? -1 -2 + ? -1 + ? -1 -2 + ? -1 -2 )) -;; 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 nargs)) +(define-record ( nargs nrest nlocs nexts)) + +(define-type + (| + ;; Meta operations + ( vars body) + ( vars) + () + ( loc) + ;; Objects + () + ( obj) + ;; Variables + ( op index) + ( op index) + ( op depth index) + ( op module name) + ;; Controls + ( label) + ( inst label) + ( inst nargs))) ;;; ;;; Parser ;;; -;; FIXME: This is not working now - ;;; (define (parse-glil x) ;;; (match x ;;; (('@asm args . body) @@ -140,9 +145,12 @@ (define (unparse glil) (match glil ;; meta - (($ nargs nrest nlocs nexts body) - `(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body))) - (($ type syms) `(,type ,@syms)) + (($ vars body) + `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts) + ,@(map unparse body))) + (($ vars) `(@bind ,@vars)) + (($ ) `(@unbind)) + (($ loc) `(@source ,(car loc) ,(cdr loc))) ;; constants (($ ) `(void)) (($ obj) `(const ,obj)) @@ -165,16 +173,17 @@ ;;; Printer ;;; -(define (pprint-glil glil) - (let print ((code (unparse glil)) (column 0)) - (display (make-string column #\space)) - (cond ((and (pair? code) (eq? (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)) +(define (pprint-glil glil . port) + (let ((port (if (pair? port) (car port) (current-output-port)))) + (let print ((code (unparse glil)) (column 0)) + (display (make-string column #\space) port) + (cond ((and (pair? code) (eq? (car code) '@asm)) + (format port "(@asm ~A\n" (cadr code)) + (let ((col (+ column 2))) + (let loop ((l (cddr code))) + (print (car l) col) + (if (null? (cdr l)) + (display ")" port) + (begin (newline port) (loop (cdr l))))))) + (else (write code port)))) + (newline port))) diff --git a/module/system/repl/.cvsignore b/module/system/repl/.cvsignore index e796b66a8..1cd7f2514 100644 --- a/module/system/repl/.cvsignore +++ b/module/system/repl/.cvsignore @@ -1 +1,3 @@ +Makefile +Makefile.in *.go diff --git a/module/system/repl/Makefile.am b/module/system/repl/Makefile.am new file mode 100644 index 000000000..e25c5d01b --- /dev/null +++ b/module/system/repl/Makefile.am @@ -0,0 +1,12 @@ +SOURCES = repl.scm common.scm command.scm +OBJECTS = repl.go common.go command.go + +vmdir = $(guiledir)/system/repl +vm_DATA = $(SOURCES) $(OBJECTS) + +DISTCLEANFILES = $(OBJECTS) +MAINTAINERCLEANFILES = Makefile.in + +SUFFIXES = .scm .go +.scm.go: + $(GUILEC) $< diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 06b6f91b5..4a08eda14 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -24,10 +24,13 @@ :use-module (system base compile) :use-module (system repl common) :use-module (system vm core) + :autoload (system base language) (lookup-language) :autoload (system il glil) (pprint-glil) :autoload (system vm disasm) (disassemble-program disassemble-objcode) :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) :autoload (system vm profile) (vm-profile) + :autoload (system vm debugger) (vm-debugger) + :autoload (system vm backtrace) (vm-backtrace) :use-module (ice-9 format) :use-module (ice-9 session) :use-module (ice-9 documentation)) @@ -44,7 +47,7 @@ (compile (compile c) (compile-file cc) (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr)) - (debug (backtrace bt) (debugger db) (trace r) (step st)) + (debug (backtrace bt) (debugger db) (trace tr) (step st)) (system (gc) (statistics stat)))) (define (group-name g) (car g)) @@ -332,16 +335,15 @@ Profile execution." ;;; Debug commands ;;; -(define guile:backtrace backtrace) (define (backtrace repl) "backtrace -Show backtrace (if any)." - (guile:backtrace)) +Display backtrace." + (vm-backtrace repl.env.vm)) (define (debugger repl) "debugger Start debugger." - (debug)) + (vm-debugger repl.env.vm)) (define (trace repl form . opts) "trace FORM diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 4c5092b9d..ba3fe5aa5 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -20,19 +20,17 @@ ;;; Code: (define-module (system repl common) - :use-module (oop goops) :use-syntax (system base syntax) :use-module (system base compile) :use-module (system base language) - :use-module (system vm core) - :use-module (system vm trace)) + :use-module (system vm core)) ;;; ;;; Repl type ;;; -(define-vm-class () env options tm-stats gc-stats vm-stats) +(define-record ( env options tm-stats gc-stats vm-stats)) (define repl-default-options '((trace . #f))) @@ -41,12 +39,11 @@ (let ((cenv (make-cenv :vm (the-vm) :language (lookup-language lang) :module (current-module)))) - (make - :env cenv - :options repl-default-options - :tm-stats (times) - :gc-stats (gc-stats) - :vm-stats (vm-stats cenv.vm)))) + ( :env cenv + :options repl-default-options + :tm-stats (times) + :gc-stats (gc-stats) + :vm-stats (vm-stats cenv.vm)))) (define-public (repl-welcome repl) (format #t "~A interpreter ~A on Guile ~A\n" diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index a77213280..485287166 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -32,15 +32,19 @@ (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)))))) + (catch 'vm-error + (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))))) + (lambda (key fun msg args) + (display "ERROR: ") + (apply format #t msg args) + (newline))) (prompt-loop)))) (define (next-char wait) @@ -50,21 +54,3 @@ ((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/.cvsignore b/module/system/vm/.cvsignore index e796b66a8..1cd7f2514 100644 --- a/module/system/vm/.cvsignore +++ b/module/system/vm/.cvsignore @@ -1 +1,3 @@ +Makefile +Makefile.in *.go diff --git a/module/system/vm/Makefile.am b/module/system/vm/Makefile.am new file mode 100644 index 000000000..fbeedaa5b --- /dev/null +++ b/module/system/vm/Makefile.am @@ -0,0 +1,12 @@ +SOURCES = assemble.scm conv.scm core.scm disasm.scm profile.scm trace.scm +OBJECTS = assemble.go conv.go core.go disasm.go profile.go trace.go + +vmdir = $(guiledir)/system/vm +vm_DATA = $(SOURCES) $(OBJECTS) + +DISTCLEANFILES = $(OBJECTS) +MAINTAINERCLEANFILES = Makefile.in + +SUFFIXES = .scm .go +.scm.go: + $(GUILEC) $< diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 1e9e2d6f8..fb8705812 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -20,6 +20,7 @@ ;;; Code: (define-module (system vm assemble) + :use-syntax (system base syntax) :use-module (system il glil) :use-module (system vm core) :use-module (system vm conv) @@ -36,11 +37,11 @@ ;;; 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 nexts bytes objs closure?)) +(define-record ( venv glil body)) +(define-record ( parent nexts closure?)) +(define-record ( id)) +(define-record ( module name)) +(define-record ( vars bytes meta objs closure?)) ;;; @@ -49,15 +50,15 @@ (define (preprocess x e) (match x - (($ nargs nrest nlocs nexts body) - (let* ((venv (make-venv e nexts #f)) + (($ vars body) + (let* ((venv ( :parent e :nexts vars.nexts :closure? #f)) (body (map (lambda (x) (preprocess x venv)) body))) - (make- venv x body))) + ( :venv venv :glil x :body body))) (($ op depth index) (do ((d depth (1- d)) - (e e (venv-parent e))) + (e e e.parent)) ((= d 0)) - (set-venv-closure?! e #t)) + (set! e.closure? #t)) x) (else x))) @@ -68,8 +69,10 @@ (define (codegen glil toplevel) (match glil - (($ venv ($ nargs nrest nlocs nexts _) body) + (($ venv ($ vars _) body) (let ((stack '()) + (bind-alist '()) + (source-alist '()) (label-alist '()) (object-alist '())) (define (push-code! code) @@ -84,11 +87,32 @@ (set! object-alist (acons x i object-alist)) i))))) (push-code! `(object-ref ,i)))))) + (define (current-address) + (define (byte-length x) + (cond ((string? x) (string-length x)) + (else 3))) + (apply + (map byte-length stack))) (define (generate-code x) (match x (($ venv) (push-object! (codegen x #f)) - (if (venv-closure? venv) (push-code! `(make-closure)))) + (if venv.closure? (push-code! `(make-closure)))) + + (($ binds) + (let ((binds (map (lambda (v) + (case (cadr v) + ((argument) (list (car v) #f (caddr v))) + ((local) (list (car v) #f + (+ vars.nargs (caddr v)))) + ((external) (list (car v) #t (caddr v))))) + binds))) + (set! bind-alist (acons (current-address) binds bind-alist)))) + + (($ ) + (set! bind-alist (acons (current-address) #f bind-alist))) + + (($ loc) + (set! source-alist (acons (current-address) loc source-alist))) (($ ) (push-code! '(void))) @@ -103,30 +127,26 @@ (($ op index) (if (eq? op 'ref) - (push-code! `(local-ref ,(+ nargs index))) - (push-code! `(local-set ,(+ nargs index))))) + (push-code! `(local-ref ,(+ vars.nargs index))) + (push-code! `(local-set ,(+ vars.nargs index))))) (($ op depth index) - (do ((e venv (venv-parent e)) + (do ((e venv e.parent) (d depth (1- d)) - (n 0 (+ n (venv-nexts e)))) + (n 0 (+ n e.nexts))) ((= d 0) (if (eq? op 'ref) (push-code! `(external-ref ,(+ n index))) (push-code! `(external-set ,(+ n index))))))) (($ op module name) - (push-object! (make-vlink #f name)) ;; FIXME: (make-vmod module) + (push-object! ( :module #f :name name)) (if (eq? op 'ref) (push-code! '(variable-ref)) (push-code! '(variable-set)))) (($ label) - (define (byte-length x) - (cond ((string? x) (string-length x)) - (else 3))) - (let ((addr (apply + (map byte-length stack)))) - (set! label-alist (assq-set! label-alist label addr)))) + (set! label-alist (assq-set! label-alist label (current-address)))) (($ inst label) (set! stack (cons (list inst label) stack))) @@ -146,13 +166,21 @@ (for-each generate-code body) (let ((bytes (stack->bytes (reverse! stack) label-alist))) (if toplevel - (bytecode->objcode bytes nlocs nexts) - (let ((objs (map car (reverse! object-alist)))) - (make-bytespec nargs nrest nlocs nexts bytes objs - (venv-closure? venv))))))))) + (bytecode->objcode bytes vars.nlocs vars.nexts) + ( :vars vars :bytes bytes + :meta (if (and (null? bind-alist) + (null? source-alist)) + #f + (cons (reverse! bind-alist) + (reverse! source-alist))) + :objs (let ((objs (map car (reverse! object-alist)))) + (if (null? objs) #f (list->vector objs))) + :closure? venv.closure?))))))) (define (object-assoc x alist) - (if (vlink? x) (assoc x alist) (assq x alist))) + (match x + (($ ) (assoc x alist)) + (else (assq x alist)))) (define (stack->bytes stack label-alist) (let loop ((result '()) (stack stack) (addr 0)) @@ -181,60 +209,63 @@ (let dump! ((x x)) (cond ((object->code x) => push-code!) - ((bytespec? x) + (else (match x - (($ bytespec nargs nrest nlocs nexts bytes objs closure?) + (($ vars bytes meta objs closure?) ;; dump parameters - (cond - ((and (< nargs 4) (< nlocs 8) (< nexts 4)) - ;; 8-bit representation - (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts))) - (push-code! `(make-int8 ,x)))) - ((and (< nargs 16) (< nlocs 128) (< nexts 16)) - ;; 16-bit representation - (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts))) - (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256))))) - (else - ;; Other cases - (push-code! (object->code nargs)) - (push-code! (object->code nrest)) - (push-code! (object->code nlocs)) - (push-code! (object->code nexts)) - (push-code! (object->code #f)))) + (let ((nargs vars.nargs) (nrest vars.nrest) + (nlocs vars.nlocs) (nexts vars.nexts)) + (cond + ((and (< nargs 4) (< nlocs 8) (< nexts 4)) + ;; 8-bit representation + (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts))) + (push-code! `(make-int8 ,x)))) + ((and (< nargs 16) (< nlocs 128) (< nexts 16)) + ;; 16-bit representation + (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts))) + (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256))))) + (else + ;; Other cases + (push-code! (object->code nargs)) + (push-code! (object->code nrest)) + (push-code! (object->code nlocs)) + (push-code! (object->code nexts)) + (push-code! (object->code #f))))) ;; dump object table - (cond ((not (null? objs)) - (for-each dump! objs) - (push-code! `(vector ,(length objs))))) + (if objs (dump! objs)) + ;; dump meta data + (if meta (dump! meta)) ;; dump bytecode - (push-code! `(load-program ,bytes))))) - ((vlink? x) - ;;; (dump! (vlink-module x)) ;; FIXME: no module support now - (push-code! `(link ,(symbol->string (vlink-name x))))) - ((vmod? x) - (push-code! `(load-module ,(vmod-id x)))) - ((and (integer? x) (exact? x)) - (let ((str (do ((n x (quotient n 256)) - (l '() (cons (modulo n 256) l))) - ((= n 0) - (list->string (map integer->char l)))))) - (push-code! `(load-integer ,str)))) - ((number? x) - (push-code! `(load-number ,(number->string x)))) - ((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) - (for-each dump! x) - (push-code! `(list ,(length x)))) - ((pair? x) - (dump! (car x)) - (dump! (cdr x)) - (push-code! `(cons))) - ((vector? x) - (for-each dump! (vector->list x)) - (push-code! `(vector ,(vector-length x)))) - (else - (error "Cannot dump:" x))))) + (push-code! `(load-program ,bytes))) + (($ module name) + ;; FIXME: dump module + (push-code! `(link ,(symbol->string name)))) + (($ id) + (push-code! `(load-module ,id))) + ((and ($ integer) ($ exact)) + (let ((str (do ((n x (quotient n 256)) + (l '() (cons (modulo n 256) l))) + ((= n 0) + (list->string (map integer->char l)))))) + (push-code! `(load-integer ,str)))) + (($ number) + (push-code! `(load-number ,(number->string x)))) + (($ string) + (push-code! `(load-string ,x))) + (($ symbol) + (push-code! `(load-symbol ,(symbol->string x)))) + (($ keyword) + (push-code! `(load-keyword + ,(symbol->string (keyword-dash-symbol x))))) + (($ list) + (for-each dump! x) + (push-code! `(list ,(length x)))) + (($ pair) + (dump! (car x)) + (dump! (cdr x)) + (push-code! `(cons))) + (($ vector) + (for-each dump! (vector->list x)) + (push-code! `(vector ,(vector-length x)))) + (else + (error "Cannot dump:" x))))))) diff --git a/module/system/vm/backtrace.scm b/module/system/vm/backtrace.scm new file mode 100644 index 000000000..a6c6111e1 --- /dev/null +++ b/module/system/vm/backtrace.scm @@ -0,0 +1,33 @@ +;;; Guile VM backtrace + +;; 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 backtrace) + :use-syntax (system base syntax) + :use-module (system vm core) + :use-module (system vm frame) + :use-module (ice-9 format) + :export (vm-backtrace)) + +(define (vm-backtrace vm) + (let ((stack (vm-last-frame-stack vm))) + (if (null? stack) + (display "No backtrace available\n") + (for-each print-frame (reverse! stack))))) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index a4a0ef4fc..fc7eca125 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -35,36 +35,21 @@ ;;; -;;; Loader +;;; High-level procedures ;;; -(define-public (vm-load vm objcode) - (vm (objcode->program objcode))) - -(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file)))) - - -;;; -;;; Frame interface -;;; - -(define-public (frame->call frame) - (let* ((prog (frame-program frame)) - (nargs (car (program-arity prog)))) - (do ((i 0 (1+ i)) - (l (vector->list (frame-variables frame)) (cdr l)) - (r '() (cons (car l) r))) - ((= i nargs) (cons (program-name prog) (reverse! r)))))) +(define-public (program-bindings prog) + (cond ((program-meta prog) => car) + (else '()))) -(define (program-name x) - (or (object-property x 'name) - (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x - (module-obarray (current-module))))) - - -;;; -;;; Statistics interface -;;; +(define-public (program-sources prog) + (cond ((program-meta prog) => cdr) + (else '()))) (define-public (vms:time stat) (vector-ref stat 0)) (define-public (vms:clock stat) (vector-ref stat 1)) + +(define-public (vm-load vm objcode) + (vm (objcode->program objcode))) + +(set! load-compiled (lambda (file) (vm-load (the-vm) (load-objcode file)))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index b8574286e..0bdcc8a56 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -127,8 +127,7 @@ (else #f))))))) (define (list->info list) - (let ((str (object->string list))) - (substring str 1 (1- (string-length str))))) + (object->string list)) (define (print-info addr info extra) (if extra diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm new file mode 100644 index 000000000..3e036cef9 --- /dev/null +++ b/module/system/vm/frame.scm @@ -0,0 +1,125 @@ +;;; Guile VM frame functions + +;; 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)) + +(define-public (vm-return-value vm) + (car (vm-fetch-stack vm))) + +(define-public (frame-local-ref frame index) + (vector-ref (frame-local-variables frame) index)) + +(define-public (frame-external-ref frame index) + (list-ref (frame-external-link frame) index)) + + +;;; +;;; Debug frames +;;; + +(define-public frame-index (make-object-property)) +(define-public frame-address (make-object-property)) + +(define-public (vm-last-frame-stack vm) + (make-frame-stack (vm-last-frame vm) (vm:ip vm))) + +(define-public (vm-current-frame-stack vm) + (make-frame-stack (vm-current-frame vm) (vm:ip vm))) + +(define (make-frame-stack frame addr) + (cond ((frame-dynamic-link frame) => + (lambda (link) + (let ((stack (make-frame-stack link (frame-return-address frame))) + (base (program-base (frame-program frame)))) + (set! (frame-index frame) (1+ (length stack))) + (set! (frame-address frame) (- addr base)) + (cons frame stack)))) + (else '()))) + +(define-public (frame-bindings frame addr) + (do ((bs (program-bindings (frame-program frame)) (cdr bs)) + (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls)))) + ((or (null? bs) (> (caar bs) addr)) + (apply append ls)))) + +(define-public (frame-environment frame addr) + (map (lambda (binding) + (let ((name (car binding)) + (extp (cadr binding)) + (index (caddr binding))) + (cons name (if extp + (frame-external-ref frame index) + (frame-local-ref frame index))))) + (frame-bindings frame addr))) + +(define (frame-variable-ref frame sym) + (cond ((assq sym (frame-environment frame)) => cdr) + (else (error "Unbound")))) + +(define (frame-object-name frame obj) + (display (frame-address frame)) + (let loop ((alist (frame-environment frame (frame-address frame)))) + (cond ((null? alist) #f) + ((eq? obj (cdar alist)) (caar alist)) + (else (loop (cdr alist)))))) + + +;;; +;;; Pretty printing +;;; + +(define-public (frame-call-list frame) + (let* ((prog (frame-program frame)) + (locs (vector->list (frame-local-variables frame))) + (args (list-truncate locs (car (program-arity prog)))) + (name (or (frame-object-name (frame-dynamic-link frame) prog) + (object-name prog)))) + (cons name args))) + +(define-public (print-frame-call frame) + (define (abbrev x) + (cond ((list? x) (if (> (length x) 3) + (list (abbrev (car x)) (abbrev (cadr x)) '...) + (map abbrev x))) + ((pair? x) (cons (abbrev (car x)) (abbrev (cdr x)))) + ((vector? x) (case (vector-length x) + ((0) x) + ((1) (vector (abbrev (vector-ref x 0)))) + (else (vector (abbrev (vector-ref x 0)) '...)))) + (else x))) + (write (abbrev (frame-call-list frame)))) + +(define-public (print-frame frame) + (format #t "#~A " (frame-index frame)) + (print-frame-call frame) + (newline)) + +(define (list-truncate l n) + (do ((i 0 (1+ i)) + (l l (cdr l)) + (r '() (cons (car l) r))) + ((= i n) (reverse! r)))) + +(define (object-name x) + (or (object-property x 'name) + (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) + x (module-obarray (current-module))))) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm index 1b29850f1..cc2760f4c 100644 --- a/module/system/vm/profile.scm +++ b/module/system/vm/profile.scm @@ -34,7 +34,7 @@ (add-hook! (vm-enter-hook vm) profile-enter) (add-hook! (vm-exit-hook vm) profile-exit)) (lambda () - (let ((val (vm (objcode->program objcode)))) + (let ((val (vm-load vm objcode))) (display-result vm) val)) (lambda () diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 364069156..f36f288cd 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -22,13 +22,14 @@ (define-module (system vm trace) :use-syntax (system base syntax) :use-module (system vm core) + :use-module (system vm frame) :use-module (ice-9 format) :export (vm-trace vm-trace-on vm-trace-off)) (define (vm-trace vm objcode . opts) (dynamic-wind (lambda () (apply vm-trace-on vm opts)) - (lambda () (vm (objcode->program objcode))) + (lambda () (vm-load vm objcode)) (lambda () (apply vm-trace-off vm opts)))) (define (vm-trace-on vm . opts) @@ -44,30 +45,32 @@ (remove-hook! (vm-return-hook vm) trace-return)) (define (trace-next vm) - (let ((frame (vm-current-frame vm))) - (format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm)) - (do ((opts (vm-option vm 'trace-options) (cdr opts))) - ((null? opts) (newline)) - (case (car opts) - ((:s) (format #t "~20S" (vm-fetch-stack vm))) - ((:v) (format #t "~20S" (frame-variables frame))) - ((:e) (format #t "~20A" (object->string (frame-external-link frame)))))))) + (format #t "0x~8X ~20S" (vm:ip vm) (vm-fetch-code vm)) + (do ((opts (vm-option vm 'trace-options) (cdr opts))) + ((null? opts) (newline)) + (case (car opts) + ((:s) (format #t "~20S" (vm-fetch-stack vm))) + ((:v) (let ((stack (vm-current-frame-stack vm))) + (if (pair? stack) + (format #t "~20S" (frame-environment (car stack)))))) + ((:l) + (format #t "~20S" (frame-local-variables (vm-current-frame vm)))) + ((:e) + (format #t "~20A" (frame-external-link (vm-current-frame vm))))))) (define (trace-apply vm) - (if (vm-option vm 'trace-first) - (set-vm-option! vm 'trace-first #f) ;; skip the initial program - (let ((frame (vm-current-frame vm))) - (print-prefix (frame-dynamic-link frame)) - (write (frame->call frame)) - (newline)))) + ;; (if (vm-option vm 'trace-first) + ;; (set-vm-option! vm 'trace-first #f) + (let ((stack (vm-current-frame-stack vm))) + (print-indent stack) + (print-frame-call (car stack)) + (newline))) (define (trace-return vm) - (let ((frame (vm-current-frame vm))) - (print-prefix (frame-dynamic-link frame)) - (write (car (vm-fetch-stack vm))) + (let ((stack (vm-current-frame-stack vm))) + (print-indent stack) + (write (vm-return-value vm)) (newline))) -(define (print-prefix frame) - (and-let* ((link (frame-dynamic-link frame))) - (display "| ") - (print-prefix link))) +(define (print-indent stack) + (cond ((pair? stack) (display "| ") (print-indent (cdr stack))))) diff --git a/src/Makefile.am b/src/Makefile.am index dcdd6eee3..311b6e7a3 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -5,14 +5,14 @@ guile_vm_LDADD = libguilevm.la guile_vm_LDFLAGS = $(GUILE_LDFLAGS) lib_LTLIBRARIES = libguilevm.la -libguilevm_la_SOURCES = \ - envs.c instructions.c objcodes.c programs.c vm.c \ - envs.h instructions.h objcodes.h programs.h vm.h \ +libguilevm_la_SOURCES = \ + envs.c frames.c instructions.c objcodes.c programs.c vm.c \ + envs.h frames.h instructions.h objcodes.h programs.h vm.h \ vm_engine.h vm_expand.h libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \ - envs.x instructions.x objcodes.x programs.x vm.x + envs.x frames.x instructions.x objcodes.x programs.x vm.x INCLUDES = $(GUILE_CFLAGS) DISTCLEANFILES = $(BUILT_SOURCES) diff --git a/src/frames.c b/src/frames.c new file mode 100644 index 000000000..382342008 --- /dev/null +++ b/src/frames.c @@ -0,0 +1,184 @@ +/* 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 "frames.h" + + +scm_bits_t scm_tc16_heap_frame; + +SCM +scm_c_make_heap_frame (SCM *fp) +{ + struct scm_heap_frame *p = + scm_must_malloc (sizeof (struct scm_heap_frame), "make_heap_frame"); + p->fp = fp; + p->program = SCM_UNDEFINED; + p->variables = SCM_UNDEFINED; + p->dynamic_link = SCM_UNDEFINED; + p->external_link = SCM_UNDEFINED; + SCM_RETURN_NEWSMOB (scm_tc16_heap_frame, p); +} + +static SCM +heap_frame_mark (SCM obj) +{ + struct scm_heap_frame *p = SCM_HEAP_FRAME_DATA (obj); + scm_gc_mark (p->program); + scm_gc_mark (p->variables); + scm_gc_mark (p->dynamic_link); + return p->external_link; +} + +/* Scheme interface */ + +SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_frame_p +{ + return SCM_BOOL (SCM_HEAP_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_HEAP_FRAME (1, frame); + return SCM_STACK_FRAME_PROGRAM (SCM_HEAP_FRAME_DATA (frame)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_frame_local_variables, "frame-local-variables", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_local_variables +{ + struct scm_heap_frame *p; + + SCM_VALIDATE_HEAP_FRAME (1, frame); + p = SCM_HEAP_FRAME_DATA (frame); + + if (SCM_UNBNDP (p->variables)) + { + SCM prog = scm_frame_program (frame); + struct scm_program *pp = SCM_PROGRAM_DATA (prog); + int i, size = pp->nargs + pp->nlocs; + p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F); + for (i = 0; i < size; i++) + SCM_VELTS (p->variables)[i] = SCM_STACK_FRAME_VARIABLE (p->fp, i); + } + return p->variables; +} +#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_HEAP_FRAME (1, frame); + + return scm_long2num ((long) SCM_VM_BYTE_ADDRESS + (SCM_STACK_FRAME_RETURN_ADDRESS + (SCM_HEAP_FRAME_DATA (frame)->fp))); +} +#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 +{ + struct scm_heap_frame *p; + + SCM_VALIDATE_HEAP_FRAME (1, frame); + p = SCM_HEAP_FRAME_DATA (frame); + + if (SCM_UNBNDP (p->dynamic_link)) + { + SCM *fp = SCM_VM_STACK_ADDRESS (SCM_STACK_FRAME_DYNAMIC_LINK (p->fp)); + if (fp) + p->dynamic_link = scm_c_make_heap_frame (fp); + else + p->dynamic_link = SCM_BOOL_F; + } + + return p->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 +{ + struct scm_heap_frame *p; + + SCM_VALIDATE_HEAP_FRAME (1, frame); + p = SCM_HEAP_FRAME_DATA (frame); + + if (SCM_UNBNDP (p->external_link)) + p->external_link = SCM_STACK_FRAME_EXTERNAL_LINK (p->fp); + + return p->external_link; +} +#undef FUNC_NAME + + +void +scm_init_frames (void) +{ + scm_tc16_heap_frame = scm_make_smob_type ("heap_frame", 0); + scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark); + +#ifndef SCM_MAGIC_SNARFER +#include "frames.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/frames.h b/src/frames.h new file mode 100644 index 000000000..ed28e56a8 --- /dev/null +++ b/src/frames.h @@ -0,0 +1,126 @@ +/* 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 _SCM_FRAMES_H_ +#define _SCM_FRAMES_H_ + +#include +#include "config.h" +#include "programs.h" + +/* + * VM Address + */ + +#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr) +#define SCM_VM_STACK_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr)) + +#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr) +#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr)) + + +/* + * VM Stack frames + */ + +/* Stack frames are allocated on the VM stack as follows: + + | | <- fp + bp->nargs + bp->nlocs + 3 + +------------------+ = SCM_STACK_FRAME_UPPER_ADDRESS (fp) + | Return address | + | Dynamic link | + | External link | <- fp + bp->nargs + bp->nlocs + | Local varialbe 1 | = SCM_STACK_FRAME_DATA_ADDRESS (fp) + | Local variable 0 | <- fp + bp->nargs + | Argument 1 | + | Argument 0 | <- fp + | Program | <- fp - 1 + +------------------+ = SCM_STACK_FRAME_LOWER_ADDRESS (fp) + | | +*/ + +#define SCM_STACK_FRAME_DATA_ADDRESS(fp) \ + (fp + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nargs \ + + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nlocs) +#define SCM_STACK_FRAME_UPPER_ADDRESS(fp) \ + (SCM_STACK_FRAME_DATA_ADDRESS (fp) + 3) +#define SCM_STACK_FRAME_LOWER_ADDRESS(fp) (fp - 1) + +#define SCM_STACK_FRAME_RETURN_ADDRESS(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[2] +#define SCM_STACK_FRAME_DYNAMIC_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[1] +#define SCM_STACK_FRAME_EXTERNAL_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[0] +#define SCM_STACK_FRAME_VARIABLE(fp,i) fp[i] +#define SCM_STACK_FRAME_PROGRAM(fp) fp[-1] + + +/* + * VM Heap frames + */ + +struct scm_heap_frame { + SCM *fp; + SCM program; + SCM variables; + SCM dynamic_link; + SCM external_link; +}; + +extern scm_bits_t scm_tc16_heap_frame; + +#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x) +#define SCM_HEAP_FRAME_DATA(f) ((struct scm_heap_frame *) SCM_SMOB_DATA (f)) +#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P) + +#define SCM_HEAP_FRAME_PROGRAM(f) SCM_HEAP_FRAME_DATA (f)->program +#define SCM_HEAP_FRAME_VARIABLES(f) SCM_HEAP_FRAME_DATA (f)->variables +#define SCM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_HEAP_FRAME_DATA (f)->dynamic_link +#define SCM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_HEAP_FRAME_DATA (f)->external_link + +extern SCM scm_c_make_heap_frame (SCM *fp); +extern void scm_init_frames (void); + +#endif /* _SCM_FRAMES_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/src/objcodes.c b/src/objcodes.c index 0df3be0f3..cff27215b 100644 --- a/src/objcodes.c +++ b/src/objcodes.c @@ -194,14 +194,16 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0, SCM prog; size_t size; char *base; + struct scm_program *p; SCM_VALIDATE_OBJCODE (1, objcode); base = SCM_OBJCODE_BASE (objcode); size = SCM_OBJCODE_SIZE (objcode); prog = scm_c_make_program (base + 10, size - 10, objcode); - SCM_PROGRAM_NLOCS (prog) = base[8]; - SCM_PROGRAM_NEXTS (prog) = base[9]; + p = SCM_PROGRAM_DATA (prog); + p->nlocs = base[8]; + p->nexts = base[9]; return prog; } #undef FUNC_NAME diff --git a/src/programs.c b/src/programs.c index 2bc4611fa..797cebeea 100644 --- a/src/programs.c +++ b/src/programs.c @@ -59,6 +59,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder) p->nrest = 0; p->nlocs = 0; p->nexts = 0; + p->meta = SCM_BOOL_F; p->objs = zero_vector; p->external = SCM_EOL; p->holder = holder; @@ -78,7 +79,7 @@ scm_c_make_closure (SCM program, SCM external) { SCM prog = scm_c_make_program (0, 0, program); *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program); - SCM_PROGRAM_EXTERNAL (prog) = external; + SCM_PROGRAM_DATA (prog)->external = external; return prog; } @@ -86,6 +87,7 @@ 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; @@ -105,19 +107,6 @@ program_free (SCM obj) return size; } -static int -program_print (SCM obj, SCM port, scm_print_state *pstate) -{ - SCM name = scm_object_property (obj, scm_sym_name); - scm_puts ("#', port); - return 1; -} - static SCM program_apply (SCM program, SCM args) { @@ -138,16 +127,41 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, } #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_long2num ((long) SCM_PROGRAM_DATA (program)->base); +} +#undef FUNC_NAME + SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, (SCM program), "") #define FUNC_NAME s_scm_program_arity +{ + struct scm_program *p; + + SCM_VALIDATE_PROGRAM (1, program); + + p = SCM_PROGRAM_DATA (program); + return SCM_LIST4 (SCM_MAKINUM (p->nargs), + SCM_MAKINUM (p->nrest), + SCM_MAKINUM (p->nlocs), + SCM_MAKINUM (p->nexts)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_meta { SCM_VALIDATE_PROGRAM (1, program); - return SCM_LIST4 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)), - SCM_MAKINUM (SCM_PROGRAM_NREST (program)), - SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)), - SCM_MAKINUM (SCM_PROGRAM_NEXTS (program))); + return SCM_PROGRAM_DATA (program)->meta; } #undef FUNC_NAME @@ -157,7 +171,7 @@ SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, #define FUNC_NAME s_scm_program_objects { SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_OBJS (program); + return SCM_PROGRAM_DATA (program)->objs; } #undef FUNC_NAME @@ -167,7 +181,7 @@ SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0, #define FUNC_NAME s_scm_program_external { SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_EXTERNAL (program); + return SCM_PROGRAM_DATA (program)->external; } #undef FUNC_NAME @@ -177,8 +191,8 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0, #define FUNC_NAME s_scm_program_bytecode { SCM_VALIDATE_PROGRAM (1, program); - return scm_makfromstr (SCM_PROGRAM_BASE (program), - SCM_PROGRAM_SIZE (program), 0); + return scm_makfromstr (SCM_PROGRAM_DATA (program)->base, + SCM_PROGRAM_DATA (program)->size, 0); } #undef FUNC_NAME @@ -191,7 +205,6 @@ scm_init_programs (void) 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 diff --git a/src/programs.h b/src/programs.h index bbea84105..ca0ab05c3 100644 --- a/src/programs.h +++ b/src/programs.h @@ -58,6 +58,7 @@ struct scm_program { unsigned char nlocs; /* the number of local variables */ unsigned char nexts; /* the number of external variables */ scm_byte_t *base; /* program base address */ + SCM meta; /* meta data */ SCM objs; /* constant objects */ SCM external; /* external environment */ SCM holder; /* the owner of bytecode */ @@ -69,18 +70,6 @@ extern scm_bits_t scm_tc16_program; #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_NEXTS(x) (SCM_PROGRAM_DATA (x)->nexts) -#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_closure (SCM program, SCM external); diff --git a/src/vm.c b/src/vm.c index ae2b7f120..dc8c3376a 100644 --- a/src/vm.c +++ b/src/vm.c @@ -40,10 +40,11 @@ * If you do not wish that, delete this exception notice. */ #include +#include "envs.h" +#include "frames.h" #include "instructions.h" -#include "programs.h" #include "objcodes.h" -#include "envs.h" +#include "programs.h" #include "vm.h" /* I sometimes use this for debugging. */ @@ -54,119 +55,6 @@ } -/* - * VM Heap frame - */ - -scm_bits_t scm_tc16_vm_heap_frame; - -static SCM -make_vm_heap_frame (SCM *fp) -{ - struct scm_vm_heap_frame *p = - scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame"); - p->fp = fp; - p->program = SCM_UNDEFINED; - p->variables = SCM_UNDEFINED; - p->dynamic_link = SCM_UNDEFINED; - p->external_link = SCM_UNDEFINED; - SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p); -} - -static SCM -vm_heap_frame_mark (SCM obj) -{ - struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj); - scm_gc_mark (p->program); - scm_gc_mark (p->variables); - scm_gc_mark (p->dynamic_link); - return p->external_link; -} - -/* 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_HEAP_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_HEAP_FRAME (1, frame); - return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_frame_variables -{ - struct scm_vm_heap_frame *p; - - SCM_VALIDATE_VM_HEAP_FRAME (1, frame); - p = SCM_VM_HEAP_FRAME_DATA (frame); - - if (SCM_UNBNDP (p->variables)) - { - SCM prog = scm_frame_program (frame); - int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog); - 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 (p->fp, i); - } - return p->variables; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_frame_dynamic_link -{ - struct scm_vm_heap_frame *p; - - SCM_VALIDATE_VM_HEAP_FRAME (1, frame); - p = SCM_VM_HEAP_FRAME_DATA (frame); - - if (SCM_UNBNDP (p->dynamic_link)) - { - SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp)); - if (fp) - p->dynamic_link = make_vm_heap_frame (fp); - else - p->dynamic_link = SCM_BOOL_F; - } - - return p->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 -{ - struct scm_vm_heap_frame *p; - - SCM_VALIDATE_VM_HEAP_FRAME (1, frame); - p = SCM_VM_HEAP_FRAME_DATA (frame); - - if (SCM_UNBNDP (p->external_link)) - p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp); - - return p->external_link; -} -#undef FUNC_NAME - - /* * VM Continuation */ @@ -303,6 +191,7 @@ make_vm (void) vp->time = 0; vp->clock = 0; vp->options = SCM_EOL; + vp->last_frame = SCM_BOOL_F; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); @@ -321,8 +210,8 @@ vm_mark (SCM obj) fp = vp->fp; while (fp) { - SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp); - SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp); + SCM *upper = SCM_STACK_FRAME_UPPER_ADDRESS (fp); + SCM *lower = SCM_STACK_FRAME_LOWER_ADDRESS (fp); /* Mark intermediate data */ for (; sp >= upper; sp--) if (SCM_NIMP (*sp)) @@ -337,6 +226,7 @@ vm_mark (SCM obj) /* Mark the options */ for (i = 0; i < SCM_VM_NUM_HOOKS; i++) scm_gc_mark (vp->hooks[i]); + scm_gc_mark (vp->last_frame); return vp->options; } @@ -553,7 +443,17 @@ SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0, { SCM_VALIDATE_VM (1, vm); VM_CHECK_RUNNING (vm); - return make_vm_heap_frame (SCM_VM_DATA (vm)->fp); + return scm_c_make_heap_frame (SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_last_frame +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->last_frame; } #undef FUNC_NAME @@ -593,7 +493,7 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, VM_CHECK_RUNNING (vm); vp = SCM_VM_DATA (vm); - for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++) + for (sp = SCM_STACK_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++) ls = scm_cons (*sp, ls); return ls; } @@ -607,12 +507,10 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0, void scm_init_vm (void) { + scm_init_frames (); scm_init_instructions (); - scm_init_programs (); scm_init_objcodes (); - - scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0); - scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark); + scm_init_programs (); scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark); diff --git a/src/vm.h b/src/vm.h index 5faac62fe..5059961ee 100644 --- a/src/vm.h +++ b/src/vm.h @@ -44,76 +44,6 @@ #include #include "config.h" -#include "programs.h" - -/* - * VM Address - */ - -#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr) -#define SCM_VM_STACK_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr)) - -#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr) -#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr)) - -/* - * VM Stack frame - */ - -/* - | | <- fp + bp->nargs + bp->nlocs + 3 - +------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp) - | Return address | - | Dynamic link | - | External link | <- fp + bp->nargs + bp->nlocs - | Local varialbe 1 | = SCM_VM_FRAME_DATA_ADDRESS (fp) - | Local variable 0 | <- fp + bp->nargs - | Argument 1 | - | Argument 0 | <- fp - | Program | <- fp - 1 - +------------------+ = SCM_VM_FRAME_LOWER_ADDRESS (fp) - | | -*/ - -#define SCM_VM_FRAME_DATA_ADDRESS(fp) \ - (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp)) \ - + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp))) -#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \ - (SCM_VM_FRAME_DATA_ADDRESS (fp) + 3) -#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1) - -#define SCM_VM_FRAME_RETURN_ADDRESS(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[2] -#define SCM_VM_FRAME_DYNAMIC_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[1] -#define SCM_VM_FRAME_EXTERNAL_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[0] -#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i] -#define SCM_VM_FRAME_PROGRAM(fp) fp[-1] - -/* - * VM Heap frame - */ - -struct scm_vm_heap_frame { - SCM *fp; - SCM program; - SCM variables; - SCM dynamic_link; - SCM external_link; -}; - -extern scm_bits_t scm_tc16_vm_heap_frame; - -#define SCM_VM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x) -#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f)) -#define SCM_VALIDATE_VM_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_HEAP_FRAME_P) - -#define SCM_VM_HEAP_FRAME_PROGRAM(f) SCM_VM_HEAP_FRAME_DATA (f)->program -#define SCM_VM_HEAP_FRAME_VARIABLES(f) SCM_VM_HEAP_FRAME_DATA (f)->variables -#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link -#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link - -/* - * VM - */ #define SCM_VM_BOOT_HOOK 0 #define SCM_VM_HALT_HOOK 1 @@ -133,6 +63,7 @@ struct scm_vm { SCM *stack_limit; /* stack limit address */ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ SCM options; /* options */ + SCM last_frame; /* last frame */ unsigned long time; /* time spent */ unsigned long clock; /* bogos clock */ }; diff --git a/src/vm_engine.c b/src/vm_engine.c index 30b8a5873..7cc93acca 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -88,7 +88,7 @@ vm_run (SCM vm, SCM program, SCM args) /* Boot program */ scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt}; - bytes[1] = scm_ilength (args); + bytes[1] = scm_ilength (args); /* FIXME: argument overflow */ program = scm_c_make_program (bytes, 3, SCM_BOOL_T); /* Initial frame */ @@ -167,10 +167,8 @@ vm_run (SCM vm, SCM program, SCM args) vm_error: SYNC_ALL (); - scm_ithrow (sym_vm_error, - SCM_LIST4 (sym_vm_run, err_msg, err_args, - scm_vm_current_frame (vm)), - 1); + vp->last_frame = scm_vm_current_frame (vm); + scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1); } abort (); /* never reached */ diff --git a/src/vm_engine.h b/src/vm_engine.h index 75d275f1c..fad35892c 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -286,7 +286,7 @@ do { \ } \ } -/* See vm.h for the layout of stack frames */ +/* See frames.h for the layout of stack frames */ #define NEW_FRAME() \ { \ diff --git a/src/vm_loader.c b/src/vm_loader.c index fe7e2b518..d221ecdd1 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -109,18 +109,27 @@ VM_DEFINE_LOADER (load_program, "load-program") { size_t len; SCM prog, x; + struct scm_program *p; FETCH_LENGTH (len); prog = scm_c_make_program (ip, len, program); + p = SCM_PROGRAM_DATA (prog); ip += len; + POP (x); + + /* init meta data */ + if (SCM_CONSP (x)) + { + p->meta = x; + POP (x); + } + /* init object table */ - x = *sp; if (SCM_VECTORP (x)) { - SCM_PROGRAM_OBJS (prog) = x; - DROP (); - x = *sp; + p->objs = x; + POP (x); } /* init parameters */ @@ -131,31 +140,31 @@ VM_DEFINE_LOADER (load_program, "load-program") if (-128 <= i && i <= 127) { /* 8-bit representation */ - SCM_PROGRAM_NARGS (prog) = (i >> 6) & 0x03; /* 7-6 bits */ - SCM_PROGRAM_NREST (prog) = (i >> 5) & 0x01; /* 5 bit */ - SCM_PROGRAM_NLOCS (prog) = (i >> 2) & 0x07; /* 4-2 bits */ - SCM_PROGRAM_NEXTS (prog) = i & 0x03; /* 1-0 bits */ + p->nargs = (i >> 6) & 0x03; /* 7-6 bits */ + p->nrest = (i >> 5) & 0x01; /* 5 bit */ + p->nlocs = (i >> 2) & 0x07; /* 4-2 bits */ + p->nexts = i & 0x03; /* 1-0 bits */ } else { /* 16-bit representation */ - SCM_PROGRAM_NARGS (prog) = (i >> 12) & 0x07; /* 15-12 bits */ - SCM_PROGRAM_NREST (prog) = (i >> 11) & 0x01; /* 11 bit */ - SCM_PROGRAM_NLOCS (prog) = (i >> 4) & 0x7f; /* 10-04 bits */ - SCM_PROGRAM_NEXTS (prog) = i & 0x0f; /* 03-00 bits */ + p->nargs = (i >> 12) & 0x07; /* 15-12 bits */ + p->nrest = (i >> 11) & 0x01; /* 11 bit */ + p->nlocs = (i >> 4) & 0x7f; /* 10-04 bits */ + p->nexts = i & 0x0f; /* 03-00 bits */ } } else { /* Other cases */ sp -= 4; - SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]); - SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]); - SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]); - SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[4]); + p->nargs = SCM_INUM (sp[0]); + p->nrest = SCM_INUM (sp[1]); + p->nlocs = SCM_INUM (sp[2]); + p->nexts = SCM_INUM (sp[3]); } - *sp = prog; + PUSH (prog); NEXT; } diff --git a/src/vm_system.c b/src/vm_system.c index 12aa02f72..e6336b435 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -187,8 +187,8 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0) #define OBJECT_REF(i) objects[i] #define OBJECT_SET(i,o) objects[i] = o -#define LOCAL_REF(i) SCM_VM_FRAME_VARIABLE (fp, i) -#define LOCAL_SET(i,o) SCM_VM_FRAME_VARIABLE (fp, i) = o +#define LOCAL_REF(i) SCM_STACK_FRAME_VARIABLE (fp, i) +#define LOCAL_SET(i,o) SCM_STACK_FRAME_VARIABLE (fp, i) = o #define VARIABLE_REF(v) SCM_CDR (v) #define VARIABLE_SET(v,o) SCM_SETCDR (v, o) @@ -379,7 +379,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) EXIT_HOOK (); reinstate_vm_cont (vp, x); CACHE_REGISTER (); - program = SCM_VM_FRAME_PROGRAM (fp); + program = SCM_STACK_FRAME_PROGRAM (fp); CACHE_PROGRAM (); NEXT; } @@ -496,7 +496,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) FREE_FRAME (); /* Restore the last program */ - program = SCM_VM_FRAME_PROGRAM (fp); + program = SCM_STACK_FRAME_PROGRAM (fp); CACHE_PROGRAM (); external = fp[bp->nargs + bp->nlocs]; PUSH (ret); -- 2.20.1