summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.cvsignore2
-rw-r--r--configure.in13
-rw-r--r--module/Makefile.am2
-rw-r--r--module/language/.cvsignore3
-rw-r--r--module/language/elisp/.cvsignore3
-rw-r--r--module/language/ghil/.cvsignore3
-rw-r--r--module/language/r5rs/.cvsignore3
-rw-r--r--module/language/scheme/.cvsignore3
-rw-r--r--module/language/scheme/translate.scm62
-rw-r--r--module/system/.cvsignore3
-rw-r--r--module/system/Makefile.am1
-rw-r--r--module/system/base/.cvsignore2
-rw-r--r--module/system/base/Makefile.am12
-rw-r--r--module/system/base/compile.scm18
-rw-r--r--module/system/base/language.scm21
-rw-r--r--module/system/base/syntax.scm143
-rw-r--r--module/system/il/.cvsignore2
-rw-r--r--module/system/il/Makefile.am12
-rw-r--r--module/system/il/compile.scm89
-rw-r--r--module/system/il/ghil.scm456
-rw-r--r--module/system/il/glil.scm103
-rw-r--r--module/system/repl/.cvsignore2
-rw-r--r--module/system/repl/Makefile.am12
-rw-r--r--module/system/repl/command.scm12
-rw-r--r--module/system/repl/common.scm17
-rw-r--r--module/system/repl/repl.scm40
-rw-r--r--module/system/vm/.cvsignore2
-rw-r--r--module/system/vm/Makefile.am12
-rw-r--r--module/system/vm/assemble.scm191
-rw-r--r--module/system/vm/backtrace.scm33
-rw-r--r--module/system/vm/core.scm39
-rw-r--r--module/system/vm/disasm.scm3
-rw-r--r--module/system/vm/frame.scm125
-rw-r--r--module/system/vm/profile.scm2
-rw-r--r--module/system/vm/trace.scm47
-rw-r--r--src/Makefile.am8
-rw-r--r--src/frames.c184
-rw-r--r--src/frames.h126
-rw-r--r--src/objcodes.c6
-rw-r--r--src/programs.c59
-rw-r--r--src/programs.h13
-rw-r--r--src/vm.c144
-rw-r--r--src/vm.h71
-rw-r--r--src/vm_engine.c8
-rw-r--r--src/vm_engine.h2
-rw-r--r--src/vm_loader.c43
-rw-r--r--src/vm_system.c8
47 files changed, 1315 insertions, 850 deletions
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-<ghil-lambda> env #f vars 0 (trans env #f x)))))
+ (<ghil-lambda> 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-<ghil-ref> e l (ghil-lookup e x))
- (trans e l y))))
- (else (make-<ghil-quote> e l x))))
+ (let ((y (symbol-expand x)))
+ (if (symbol? y)
+ (<ghil-ref> e l (ghil-lookup e y))
+ (trans e l y))))
+ (else (<ghil-quote> 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-<ghil-void> e l))
+ (define (make:void) (<ghil-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-<ghil-quote> e l obj))
+ ((obj) (<ghil-quote> e l obj))
(else (bad-syntax))))
;; (quasiquote OBJ)
((quasiquote)
(match tail
- ((obj) (make-<ghil-quasiquote> e l (trans-quasiquote e l obj)))
+ ((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
(else (bad-syntax))))
((define define-private)
(match tail
;; (define NAME VAL)
(((? symbol? name) val)
- (make-<ghil-define> e l (ghil-lookup e name) (trans:x val)))
+ (<ghil-define> 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-<ghil-define> e l (ghil-lookup e name) val)))
+ (<ghil-define> e l (ghil-lookup e name) val)))
(else (bad-syntax))))
@@ -104,7 +104,7 @@
(match tail
;; (set! NAME VAL)
(((? symbol? name) val)
- (make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+ (<ghil-set> 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-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
+ (<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
((test then else)
- (make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
+ (<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
(else (bad-syntax))))
;; (and EXPS...)
((and)
- (make-<ghil-and> e l (map trans:x tail)))
+ (<ghil-and> e l (map trans:x tail)))
;; (or EXPS...)
((or)
- (make-<ghil-or> e l (map trans:x tail)))
+ (<ghil-or> e l (map trans:x tail)))
;; (begin EXPS...)
((begin)
- (make-<ghil-begin> e l (map trans:x tail)))
+ (<ghil-begin> e l (map trans:x tail)))
((let)
(match tail
@@ -144,14 +144,14 @@
;; (let () BODY...)
((() body ...)
;; NOTE: This differs from `begin'
- (make-<ghil-begin> e l (list (trans:body body))))
+ (<ghil-begin> 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-<ghil-bind> e l vars vals (trans:body body))))))
+ (<ghil-bind> 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-<ghil-bind> e l vars vals (trans:body body))))))
+ (<ghil-bind> 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-<ghil-lambda> env l vars rest (trans-body env l body))))))
+ (<ghil-lambda> 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-<ghil-inline> e l head (map trans:x tail))
- (make-<ghil-call> e l (trans:x head) (map trans:x tail))))))
+ (<ghil-inline> e l head (map trans:x tail))
+ (<ghil-call> 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-<ghil-unquote> e l (trans e l obj))
- (make-<ghil-unquote-splicing> e l (trans e l obj))))
+ (<ghil-unquote> e l (trans e l obj))
+ (<ghil-unquote-splicing> 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 <cenv> ()
- vm language module optimize)
+(define-record (<cenv> vm language module))
(define-public (make-cenv . rest)
- (apply make <cenv> rest))
+ (apply <cenv> 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 <language> ()
- name title version environment
- reader printer read-file
- (expander (lambda (x e) x))
- (translator (lambda (x e) x))
- (evaluator #f)
- )
-
-(define-method (write (lang <language>) port)
- (display "#<language " port)
- (display lang.name port)
- (display ">"))
+(define-record (<language> 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 ,<language> :name ',name ,@spec)))
+ `(define ,name (,<language> :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* "#<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 <foo> () (x 1) (y 2)) =>
-;;
-;; (define-class <foo> ()
-;; (a :init-keyword :a :init-form 1)
-;; (b :init-keyword :b :init-form 2))
-
-(define-macro (define-vm-class name supers . rest)
- `(define-class ,name ,supers
- ,@(map (lambda (def)
- (if (not (pair? def)) (set! def (list def)))
- (let ((name (car def)) (rest (cdr def)))
- (cons* name :init-keyword (symbol->keyword name)
- (if (or (null? rest) (keyword? (car rest)))
- rest
- (cons :init-form rest)))))
- rest)))
-
-(export-syntax define-vm-class)
+(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
(($ <ghil-set> env var val)
- (make-<ghil-set> env var (optimize val)))
+ (<ghil-set> env var (optimize val)))
(($ <ghil-if> test then else)
- (make-<ghil-if> (optimize test) (optimize then) (optimize else)))
+ (<ghil-if> (optimize test) (optimize then) (optimize else)))
(($ <ghil-begin> exps)
- (make-<ghil-begin> (map optimize exps)))
+ (<ghil-begin> (map optimize exps)))
(($ <ghil-bind> env vars vals body)
- (make-<ghil-bind> env vars (map optimize vals) (optimize body)))
+ (<ghil-bind> env vars (map optimize vals) (optimize body)))
(($ <ghil-lambda> env vars rest body)
- (make-<ghil-lambda> env vars rest (optimize body)))
+ (<ghil-lambda> env vars rest (optimize body)))
(($ <ghil-inst> inst args)
- (make-<ghil-inst> inst (map optimize args)))
+ (<ghil-inst> inst (map optimize args)))
(($ <ghil-call> env proc args)
(match proc
@@ -67,9 +66,9 @@
(set! v.env env)
(ghil-env-add! env v))
lambda-env.variables)
- (optimize (make-<ghil-bind> env vars args body)))
+ (optimize (<ghil-bind> env vars args body)))
(else
- (make-<ghil-call> env (optimize proc) (map optimize args)))))
+ (<ghil-call> env (optimize proc) (map optimize args)))))
(else x)))
@@ -77,25 +76,25 @@
;;; Stage 3: Code generation
;;;
-(define *ia-void* (make-<glil-void>))
-(define *ia-drop* (make-<glil-call> 'drop 0))
-(define *ia-return* (make-<glil-call> 'return 0))
+(define *ia-void* (<glil-void>))
+(define *ia-drop* (<glil-call> 'drop 0))
+(define *ia-return* (<glil-call> 'return 0))
(define (make-label) (gensym ":L"))
(define (make-glil-var op env var)
(case var.kind
((argument)
- (make-<glil-argument> op var.index))
+ (<glil-argument> op var.index))
((local)
- (make-<glil-local> op var.index))
+ (<glil-local> op var.index))
((external)
(do ((depth 0 (1+ depth))
(e env e.parent))
((eq? e var.env)
- (make-<glil-external> op depth var.index))))
+ (<glil-external> op depth var.index))))
((module)
- (make-<glil-module> op var.env var.name))
+ (<glil-module> 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-<glil-label> label)))
+ (push-code! (<glil-label> label)))
(define (push-branch! inst label)
- (push-code! (make-<glil-branch> inst label)))
- (define (push-call! inst args)
+ (push-code! (<glil-branch> inst label)))
+ (define (push-call! loc inst args)
(for-each comp-push args)
- (push-code! (make-<glil-call> inst (length args))))
+ (push-code! (<glil-call> inst (length args)))
+ (push-code! (<glil-source> 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-<glil-const> obj)))
+ (return-code! (<glil-const> 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-<glil-call> 'cons 2)))
+ (push-code! (<glil-call> 'cons 2)))
(($ <ghil-unquote> env loc exp)
(comp-push exp))
(($ <ghil-unquote-splicing> env loc exp)
(comp-push exp)
- (push-call! 'list-break '()))
+ (push-call! #f 'list-break '()))
(else
- (push-code! (make-<glil-const> x)))))
+ (push-code! (<glil-const> x)))))
(maybe-drop)
(maybe-return))
(($ <ghil-ref> env loc var)
(return-code! (make-glil-var 'ref env var)))
- ((or ($ <ghil-set> env loc var val)
- ($ <ghil-define> env loc var val))
+ (($ <ghil-set> env loc var val)
+ (comp-push val)
+ (push-code! (make-glil-var 'set env var))
+ (return-void!))
+
+ (($ <ghil-define> 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 '())))))
(($ <ghil-begin> 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! (<glil-bind> vars))))
+ (comp-tail body)
+ (push-code! (<glil-unbind>)))
(($ <ghil-lambda> env loc vars rest body)
(return-code! (codegen tree)))
@@ -257,7 +264,7 @@
(($ <ghil-inline> 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! (<glil-bind> 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-<glil-argument> 'ref n))
- (push-code! (make-<glil-external> 'set 0 v.index))))))
+ (cond ((eq? v.kind 'external)
+ (push-code! (<glil-argument> 'ref n))
+ (push-code! (<glil-external> 'set 0 v.index))))))
;; compile body
(comp body #t #f)
;; create GLIL
- (make-<glil-asm> (length args) (if rest 1 0) (length locs)
- (length exts) (reverse! stack)))))))
+ (let ((vars (<glil-vars> :nargs (length args)
+ :nrest (if rest 1 0)
+ :nlocs (length locs)
+ :nexts (length exts))))
+ (<glil-asm> 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
index eb356a556..ea3d66e4e 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -20,42 +20,38 @@
;;; 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-<ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
- make-<ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
- make-<ghil-quasiquote> <ghil-quasiquote>?
+ (
+ <ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
+ <ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
+ <ghil-quasiquote> <ghil-quasiquote>?
<ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
- make-<ghil-unquote> <ghil-unquote>?
+ <ghil-unquote> <ghil-unquote>?
<ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
- make-<ghil-unquote-splicing> <ghil-unquote-splicing>?
+ <ghil-unquote-splicing> <ghil-unquote-splicing>?
<ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
<ghil-unquote-splicing>-3
- make-<ghil-ref> <ghil-ref>?
- <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
- make-<ghil-set> <ghil-set>?
- <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
- make-<ghil-define> <ghil-define>?
+ <ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
+ <ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
+ <ghil-define> <ghil-define>?
<ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
- make-<ghil-if> <ghil-if>?
+ <ghil-if> <ghil-if>?
<ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
- make-<ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
- make-<ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
- make-<ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
- make-<ghil-bind> <ghil-bind>?
+ <ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
+ <ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
+ <ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
+ <ghil-bind> <ghil-bind>?
<ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
- make-<ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
+ <ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
<ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
- make-<ghil-inline> <ghil-inline>?
+ <ghil-inline> <ghil-inline>?
<ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
- make-<ghil-call> <ghil-call>?
+ <ghil-call> <ghil-call>?
<ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
))
@@ -64,27 +60,30 @@
;;; Parse tree
;;;
-(define-structure (<ghil-void> env loc))
-(define-structure (<ghil-quote> env loc obj))
-(define-structure (<ghil-quasiquote> env loc exp))
-(define-structure (<ghil-unquote> env loc exp))
-(define-structure (<ghil-unquote-splicing> env loc exp))
-
-(define-structure (<ghil-ref> env loc var))
-(define-structure (<ghil-set> env loc var val))
-(define-structure (<ghil-define> env loc var val))
-
-(define-structure (<ghil-if> env loc test then else))
-(define-structure (<ghil-and> env loc exps))
-(define-structure (<ghil-or> env loc exps))
-(define-structure (<ghil-begin> env loc exps))
-(define-structure (<ghil-bind> env loc vars vals body))
-(define-structure (<ghil-lambda> env loc vars rest body))
-(define-structure (<ghil-call> env loc proc args))
-(define-structure (<ghil-inline> env loc inline args))
-
-(define-public (ghil-env ghil) (vector-ref ghil 1))
-(define-public (ghil-loc ghil) (vector-ref ghil 2))
+(define-type <ghil>
+ (|
+ ;; Objects
+ (<ghil-void> env loc)
+ (<ghil-quote> env loc obj)
+ (<ghil-quasiquote> env loc exp)
+ (<ghil-unquote> env loc exp)
+ (<ghil-unquote-splicing> env loc exp)
+ ;; Variables
+ (<ghil-ref> env loc var)
+ (<ghil-set> env loc var val)
+ (<ghil-define> env loc var val)
+ ;; Controls
+ (<ghil-if> env loc test then else)
+ (<ghil-and> env loc exps)
+ (<ghil-or> env loc exps)
+ (<ghil-begin> env loc exps)
+ (<ghil-bind> env loc vars vals body)
+ (<ghil-lambda> env loc vars rest body)
+ (<ghil-call> env loc proc args)
+ (<ghil-inline> env loc inline args)))
+
+(define-public ghil-env %slot-1)
+(define-public ghil-loc %slot-2)
;;;
@@ -96,7 +95,7 @@
(define *macro-module* (resolve-module '(system il macros)))
-(define (ghil-primitive-macro? x)
+(define-public (ghil-primitive-macro? x)
(and (module-defined? *macro-module* x)
(procedure? (module-ref *macro-module* x))))
@@ -112,78 +111,59 @@
;;; Variables
;;;
-(define-vm-class <ghil-var> ()
- env name kind type value index)
+(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
(define-public (make-ghil-var env name kind)
- (make <ghil-var> :env env :name name :kind kind))
-
-(define-method (write (var <ghil-var>) port)
- (display "#<ghil:var " port)
- (display var.name port)
- (display ">" port))
+ (<ghil-var> :env env :name name :kind kind))
;;;
;;; Modules
;;;
-(define-vm-class <ghil-mod> ()
- (module)
- (table '())
- (imports '()))
+(define-record (<ghil-mod> module (table '()) (imports '())))
(define-public (make-ghil-mod module)
- (make <ghil-mod> :module module))
-
-(define-method (write (mod <ghil-mod>) port)
- (display "#<ghil:mod " port)
- (display (module-name mod.module) port)
- (display ">" port))
-
-(define-method (ghil-lookup (mod <ghil-mod>) (sym <symbol>))
- (or (assq-ref mod.table sym)
- ;; (let ((var (make-ghil-var (env-identifier mod.module) sym 'module)))
- (let ((var (make-ghil-var #f sym 'module)))
- (set! mod.table (acons sym var mod.table))
- var)))
+ (<ghil-mod> :module module))
;;;
;;; Environments
;;;
-(define-vm-class <ghil-env> ()
- (mod)
- (parent #f)
- (table '())
- (variables '()))
+(define-record (<ghil-env> mod parent (table '()) (variables '())))
-(export make-ghil-env)
-(define-method (make-ghil-env (m <ghil-mod>))
- (make <ghil-env> :mod m :parent m))
-
-(define-method (make-ghil-env (e <ghil-env>))
- (make <ghil-env> :mod e.mod :parent e))
+(define-public (make-ghil-env e)
+ (match e
+ (($ <ghil-mod>) (<ghil-env> :mod e :parent e))
+ (($ <ghil-env> m) (<ghil-env> :mod m :parent e))))
(define (ghil-env-toplevel? e)
(eq? e.mod e.parent))
-(define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
+(define (ghil-env-ref env sym)
(assq-ref env.table sym))
-(export ghil-env-add!)
-(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
+(define-public (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 <ghil-env>) (var <ghil-var>))
+(define (ghil-env-remove! env var)
(set! env.table (assq-remove! env.table var.name)))
-(define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
+
+;;;
+;;; Public interface
+;;;
+
+(define-public (ghil-lookup env sym)
(or (ghil-env-ref env sym)
(let loop ((e env.parent))
- (cond ((is-a? e <ghil-mod>) (ghil-lookup e sym))
+ (cond ((<ghil-mod>? 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))))))
@@ -210,156 +190,156 @@
;;; Parser
;;;
-(define (parse-ghil x e)
- (parse `(@lambda () ,x) (make-ghil-mod e)))
-
-(define (parse x e)
- (cond ((pair? x) (parse-pair x e))
- ((symbol? x)
- (let ((str (symbol->string x)))
- (case (string-ref str 0)
- ((#\@) (error "Invalid use of IL primitive" x))
- ((#\:) (let ((sym (string->symbol (substring str 1))))
- (make-<ghil-quote> (symbol->keyword sym))))
- (else (make-<ghil-ref> e (ghil-lookup e x))))))
- (else (make-<ghil-quote> x))))
-
-(define (map-parse x e)
- (map (lambda (x) (parse x e)) x))
-
-(define (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-<ghil-call> e (parse head e) (map-parse tail e)))))
-
-(define (parse-primitive prim args e)
- (case prim
- ;; (@ IDENTIFIER)
- ((@)
- (match args
- (()
- (make-<ghil-ref> e (make-ghil-var '@ '@ 'module)))
- ((identifier)
- (receive (module name) (identifier-split identifier)
- (make-<ghil-ref> e (make-ghil-var module name 'module))))))
-
- ;; (@@ OP ARGS...)
- ((@@)
- (match args
- ((op . args)
- (make-<ghil-inline> op (map-parse args e)))))
-
- ;; (@void)
- ((@void)
- (match args
- (() (make-<ghil-void>))))
-
- ;; (@quote OBJ)
- ((@quote)
- (match args
- ((obj)
- (make-<ghil-quote> obj))))
-
- ;; (@define NAME VAL)
- ((@define)
- (match args
- ((name val)
- (let ((v (ghil-lookup e name)))
- (make-<ghil-set> e v (parse val e))))))
-
- ;; (@set! NAME VAL)
- ((@set!)
- (match args
- ((name val)
- (let ((v (ghil-lookup e name)))
- (make-<ghil-set> e v (parse val e))))))
-
- ;; (@if TEST THEN [ELSE])
- ((@if)
- (match args
- ((test then)
- (make-<ghil-if> (parse test e) (parse then e) (make-<ghil-void>)))
- ((test then else)
- (make-<ghil-if> (parse test e) (parse then e) (parse else e)))))
-
- ;; (@begin BODY...)
- ((@begin)
- (parse-body args e))
-
- ;; (@let ((SYM INIT)...) BODY...)
- ((@let)
- (match args
- ((((sym init) ...) body ...)
- (let* ((vals (map-parse init e))
- (vars (map (lambda (s)
- (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-<ghil-bind> 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-<ghil-bind> e vars vals body)))))
-
- ;; (@lambda FORMALS BODY...)
- ((@lambda)
- (match args
- ((formals . body)
- (receive (syms rest) (parse-formals formals)
- (let* ((e (make-ghil-env e))
- (vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'argument)))
- (ghil-env-add! e v) v))
- syms)))
- (make-<ghil-lambda> e vars rest (parse-body body e)))))))
-
- ;; (@eval-case CLAUSE...)
- ((@eval-case)
- (let loop ((clauses args))
- (cond ((null? clauses) (make-<ghil-void>))
- ((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-<ghil-begin> (map-parse x e)))
-
-(define (parse-formals formals)
- (cond
- ;; (@lambda x ...)
- ((symbol? formals) (values (list formals) #t))
- ;; (@lambda (x y z) ...)
- ((list? formals) (values formals #f))
- ;; (@lambda (x y . z) ...)
- ((pair? formals)
- (let loop ((l formals) (v '()))
- (if (pair? l)
- (loop (cdr l) (cons (car l) v))
- (values (reverse! (cons l v)) #t))))
- (else (error "Invalid formals:" formals))))
-
-(define (identifier-split identifier)
- (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
- (if m
- (values (string->symbol (match:prefix m))
- (string->symbol (match:substring m 1)))
- (values #f identifier))))
+;;; (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))))
+;;; (<ghil-quote> (symbol->keyword sym))))
+;;; (else (<ghil-ref> e (ghil-lookup e x))))))
+;;; (else (<ghil-quote> 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))
+;;; (<ghil-call> e (parse head e) (map-parse tail e)))))
+;;;
+;;; (define (parse-primitive prim args e)
+;;; (case prim
+;;; ;; (@ IDENTIFIER)
+;;; ((@)
+;;; (match args
+;;; (()
+;;; (<ghil-ref> e (make-ghil-var '@ '@ 'module)))
+;;; ((identifier)
+;;; (receive (module name) (identifier-split identifier)
+;;; (<ghil-ref> e (make-ghil-var module name 'module))))))
+;;;
+;;; ;; (@@ OP ARGS...)
+;;; ((@@)
+;;; (match args
+;;; ((op . args)
+;;; (<ghil-inline> op (map-parse args e)))))
+;;;
+;;; ;; (@void)
+;;; ((@void)
+;;; (match args
+;;; (() (<ghil-void>))))
+;;;
+;;; ;; (@quote OBJ)
+;;; ((@quote)
+;;; (match args
+;;; ((obj)
+;;; (<ghil-quote> obj))))
+;;;
+;;; ;; (@define NAME VAL)
+;;; ((@define)
+;;; (match args
+;;; ((name val)
+;;; (let ((v (ghil-lookup e name)))
+;;; (<ghil-set> e v (parse val e))))))
+;;;
+;;; ;; (@set! NAME VAL)
+;;; ((@set!)
+;;; (match args
+;;; ((name val)
+;;; (let ((v (ghil-lookup e name)))
+;;; (<ghil-set> e v (parse val e))))))
+;;;
+;;; ;; (@if TEST THEN [ELSE])
+;;; ((@if)
+;;; (match args
+;;; ((test then)
+;;; (<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
+;;; ((test then else)
+;;; (<ghil-if> (parse test e) (parse then e) (parse else e)))))
+;;;
+;;; ;; (@begin BODY...)
+;;; ((@begin)
+;;; (parse-body args e))
+;;;
+;;; ;; (@let ((SYM INIT)...) BODY...)
+;;; ((@let)
+;;; (match args
+;;; ((((sym init) ...) body ...)
+;;; (let* ((vals (map-parse init e))
+;;; (vars (map (lambda (s)
+;;; (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)
+;;; (<ghil-bind> 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)
+;;; (<ghil-bind> e vars vals body)))))
+;;;
+;;; ;; (@lambda FORMALS BODY...)
+;;; ((@lambda)
+;;; (match args
+;;; ((formals . body)
+;;; (receive (syms rest) (parse-formals formals)
+;;; (let* ((e (make-ghil-env e))
+;;; (vars (map (lambda (s)
+;;; (let ((v (make-ghil-var e s 'argument)))
+;;; (ghil-env-add! e v) v))
+;;; syms)))
+;;; (<ghil-lambda> e vars rest (parse-body body e)))))))
+;;;
+;;; ;; (@eval-case CLAUSE...)
+;;; ((@eval-case)
+;;; (let loop ((clauses args))
+;;; (cond ((null? clauses) (<ghil-void>))
+;;; ((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)
+;;; (<ghil-begin> (map-parse x e)))
+;;;
+;;; (define (parse-formals formals)
+;;; (cond
+;;; ;; (@lambda x ...)
+;;; ((symbol? formals) (values (list formals) #t))
+;;; ;; (@lambda (x y z) ...)
+;;; ((list? formals) (values formals #f))
+;;; ;; (@lambda (x y . z) ...)
+;;; ((pair? formals)
+;;; (let loop ((l formals) (v '()))
+;;; (if (pair? l)
+;;; (loop (cdr l) (cons (car l) v))
+;;; (values (reverse! (cons l v)) #t))))
+;;; (else (error "Invalid formals:" formals))))
+;;;
+;;; (define (identifier-split identifier)
+;;; (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+;;; (if m
+;;; (values (string->symbol (match:prefix m))
+;;; (string->symbol (match:substring m 1)))
+;;; (values #f identifier))))
diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
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-<glil-asm> <glil-asm>?
+ <glil-vars>
+ <glil-asm> <glil-asm>?
<glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
- make-<glil-vars> <glil-vars>? <glil-vars>-1 <glil-vars>-2
+ <glil-bind> <glil-bind>? <glil-bind>-1
+ <glil-unbind> <glil-unbind>?
+ <glil-source> <glil-source>? <glil-source>-1 <glil-source>-2
- make-<glil-void> <glil-void>?
- make-<glil-const> <glil-const>? <glil-const>-1
+ <glil-void> <glil-void>?
+ <glil-const> <glil-const>? <glil-const>-1
- make-<glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
- make-<glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
- make-<glil-external> <glil-external>?
+ <glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
+ <glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
+ <glil-external> <glil-external>?
<glil-external>-1 <glil-external>-2 <glil-external>-3
- make-<glil-module> <glil-module>?
+ <glil-module> <glil-module>?
<glil-module>-1 <glil-module>-2 <glil-module>-3
- make-<glil-label> <glil-label>? <glil-label>-1
- make-<glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
- make-<glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
+ <glil-label> <glil-label>? <glil-label>-1
+ <glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
+ <glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
))
-;; Meta operations
-(define-structure (<glil-asm> nargs nrest nlocs nexts body))
-(define-structure (<glil-vars> type syms))
-
-;; Constants
-(define-structure (<glil-void>))
-(define-structure (<glil-const> obj))
-
-;; Variables
-(define-structure (<glil-argument> op index))
-(define-structure (<glil-local> op index))
-(define-structure (<glil-external> op depth index))
-(define-structure (<glil-module> op module name))
-
-;; Controls
-(define-structure (<glil-label> label))
-(define-structure (<glil-branch> inst label))
-(define-structure (<glil-call> inst nargs))
+(define-record (<glil-vars> nargs nrest nlocs nexts))
+
+(define-type <glil>
+ (|
+ ;; Meta operations
+ (<glil-asm> vars body)
+ (<glil-bind> vars)
+ (<glil-unbind>)
+ (<glil-source> loc)
+ ;; Objects
+ (<glil-void>)
+ (<glil-const> obj)
+ ;; Variables
+ (<glil-argument> op index)
+ (<glil-local> op index)
+ (<glil-external> op depth index)
+ (<glil-module> op module name)
+ ;; Controls
+ (<glil-label> label)
+ (<glil-branch> inst label)
+ (<glil-call> 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
- (($ <glil-asm> nargs nrest nlocs nexts body)
- `(@asm (,nargs ,nrest ,nlocs ,nexts) ,@(map unparse body)))
- (($ <glil-vars> type syms) `(,type ,@syms))
+ (($ <glil-asm> vars body)
+ `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
+ ,@(map unparse body)))
+ (($ <glil-bind> vars) `(@bind ,@vars))
+ (($ <glil-unbind>) `(@unbind))
+ (($ <glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
;; constants
(($ <glil-void>) `(void))
(($ <glil-const> 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 <repl> () env options tm-stats gc-stats vm-stats)
+(define-record (<repl> 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 <repl>
- :env cenv
- :options repl-default-options
- :tm-stats (times)
- :gc-stats (gc-stats)
- :vm-stats (vm-stats cenv.vm))))
+ (<repl> :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 (<vm-asm> venv glil body))
-(define-structure (venv parent nexts closure?))
-(define-structure (vmod id))
-(define-structure (vlink module name))
-(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?))
+(define-record (<vm-asm> venv glil body))
+(define-record (<venv> parent nexts closure?))
+(define-record (<vmod> id))
+(define-record (<vlink> module name))
+(define-record (<bytespec> vars bytes meta objs closure?))
;;;
@@ -49,15 +50,15 @@
(define (preprocess x e)
(match x
- (($ <glil-asm> nargs nrest nlocs nexts body)
- (let* ((venv (make-venv e nexts #f))
+ (($ <glil-asm> vars body)
+ (let* ((venv (<venv> :parent e :nexts vars.nexts :closure? #f))
(body (map (lambda (x) (preprocess x venv)) body)))
- (make-<vm-asm> venv x body)))
+ (<vm-asm> :venv venv :glil x :body body)))
(($ <glil-external> 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
- (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
+ (($ <vm-asm> venv ($ <glil-asm> 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
(($ <vm-asm> venv)
(push-object! (codegen x #f))
- (if (venv-closure? venv) (push-code! `(make-closure))))
+ (if venv.closure? (push-code! `(make-closure))))
+
+ (($ <glil-bind> 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))))
+
+ (($ <glil-unbind>)
+ (set! bind-alist (acons (current-address) #f bind-alist)))
+
+ (($ <glil-source> loc)
+ (set! source-alist (acons (current-address) loc source-alist)))
(($ <glil-void>)
(push-code! '(void)))
@@ -103,30 +127,26 @@
(($ <glil-local> 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)))))
(($ <glil-external> 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)))))))
(($ <glil-module> op module name)
- (push-object! (make-vlink #f name)) ;; FIXME: (make-vmod module)
+ (push-object! (<vlink> :module #f :name name))
(if (eq? op 'ref)
(push-code! '(variable-ref))
(push-code! '(variable-set))))
(($ <glil-label> 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))))
(($ <glil-branch> 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)
+ (<bytespec> :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
+ (($ <vlink>) (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?)
+ (($ <bytespec> 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)))
+ (($ <vlink> module name)
+ ;; FIXME: dump module
+ (push-code! `(link ,(symbol->string name))))
+ (($ <vmod> 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 <string.h>
+#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 <libguile.h>
+#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 ("#<program ", port);
- if (SCM_FALSEP (name))
- scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
- else
- scm_display (name, port);
- scm_putc ('>', 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 <string.h>
+#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. */
@@ -55,119 +56,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 <libguile.h>
#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);