summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-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
33 files changed, 891 insertions, 587 deletions
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)))))