diff options
Diffstat (limited to 'module')
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))))) |