mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-22 02:13:48 +00:00
parent ac02b386c2
commit ac99cb0cb1
47 changed files with 1319 additions and 854 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.cvsignore
View file

@ -1,7 +1,7 @@
misc
libtool
config.*
configure
Makefile
Makefile.in
aclocal.m4
misc

13
configure.in
View file

@ -12,4 +12,15 @@ AC_PROG_LN_S
AM_PROG_LIBTOOL
AC_C_LABELS_AS_VALUES
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile)
guiledir="\$(datadir)/guile"
AC_SUBST(guiledir)
GUILEC="GUILE_LOAD_PATH=\$(top_srcdir)/module \
LD_LIBRARY_PATH=\$(top_srcdir)/src/.libs \
guile -s \$(top_srcdir)/src/guilec"
AC_SUBST(GUILEC)
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile
module/system/Makefile module/system/base/Makefile
module/system/vm/Makefile module/system/il/Makefile
module/system/repl/Makefile)

2
module/Makefile.am
View file

@ -1,3 +1,5 @@
SUBDIRS = system
DISTDIRS = $(srcdir)/system $(srcdir)/language $(srcdir)/guile $(srcdir)/slib
EXCLUDES = --exclude=CVS --exclude=*.go --exclude=*~

3
module/language/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

3
module/language/elisp/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

3
module/language/ghil/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

3
module/language/r5rs/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

3
module/language/scheme/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

54
module/language/scheme/translate.scm
View file

@ -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)))))
;;;
@ -46,25 +46,25 @@
(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))
(let ((y (symbol-expand x)))
(if (symbol? y)
(<ghil-ref> e l (ghil-lookup e y))
(trans e l y))))
(else (make-<ghil-quote> e l x))))
(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)))))
(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))))))

3
module/system/.cvsignore Normal file
View file

@ -0,0 +1,3 @@
Makefile
Makefile.in
*.go

1
module/system/Makefile.am Normal file
View file

@ -0,0 +1 @@
SUBDIRS = vm

2
module/system/base/.cvsignore
View file

@ -1 +1,3 @@
Makefile
Makefile.in
*.go

12
module/system/base/Makefile.am Normal file
View file

@ -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) $<

16
module/system/base/compile.scm
View file

@ -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,19 +32,17 @@
;;; 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)
(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)

15
module/system/base/language.scm
View file

@ -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
(define-record (<language> name title version 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 ">"))
(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))))

139
module/system/base/syntax.scm
View file

@ -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
;;;
;; (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-type)
(define-macro (define-type name sig) sig)
;;;
;;; Other utilities
;;; 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
;;;
(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))
;;;
;;; Utilities
;;;
(define-public (list-fold f d l)

2
module/system/il/.cvsignore
View file

@ -1 +1,3 @@
Makefile
Makefile.in
*.go

12
module/system/il/Makefile.am Normal file
View file

@ -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) $<

89
module/system/il/compile.scm
View file

@ -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))

454
module/system/il/ghil.scm
View file

@ -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-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-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-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))))

89
module/system/il/glil.scm
View file

@ -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))
(define-record (<glil-vars> nargs nrest nlocs nexts))
;; 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-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)
(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))
(display (make-string column #\space) port)
(cond ((and (pair? code) (eq? (car code) '@asm))
(format #t "(@asm ~A\n" (cadr code))
(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 ")")
(begin (newline) (loop (cdr l)))))))
(else (write code))))
(newline))
(display ")" port)
(begin (newline port) (loop (cdr l)))))))
(else (write code port))))
(newline port)))

2
module/system/repl/.cvsignore
View file

@ -1 +1,3 @@
Makefile
Makefile.in
*.go

12
module/system/repl/Makefile.am Normal file
View file

@ -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) $<

12
module/system/repl/command.scm
View file

@ -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

9
module/system/repl/common.scm
View file

@ -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,8 +39,7 @@
(let ((cenv (make-cenv :vm (the-vm)
:language (lookup-language lang)
:module (current-module))))
(make <repl>
:env cenv
(<repl> :env cenv
:options repl-default-options
:tm-stats (times)
:gc-stats (gc-stats)

26
module/system/repl/repl.scm
View file

@ -32,7 +32,7 @@
(repl-welcome repl)
(let prompt-loop ()
(repl-prompt repl)
(call-with-error-handlers
(catch 'vm-error
(lambda ()
(if (eq? (next-char #t) #\,)
;; meta command
@ -40,7 +40,11 @@
;; evaluation
(let rep-loop ()
(repl-print repl (repl-eval repl (repl-read repl)))
(if (next-char #f) (rep-loop))))))
(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))

2
module/system/vm/.cvsignore
View file

@ -1 +1,3 @@
Makefile
Makefile.in
*.go

12
module/system/vm/Makefile.am Normal file
View file

@ -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) $<

129
module/system/vm/assemble.scm
View file

@ -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,10 +209,12 @@
(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
(let ((nargs vars.nargs) (nrest vars.nrest)
(nlocs vars.nlocs) (nexts vars.nexts))
(cond
((and (< nargs 4) (< nlocs 8) (< nexts 4))
;; 8-bit representation
@ -200,41 +230,42 @@
(push-code! (object->code nrest))
(push-code! (object->code nlocs))
(push-code! (object->code nexts))
(push-code! (object->code #f))))
(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))
(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? x)
(($ number)
(push-code! `(load-number ,(number->string x))))
((string? x)
(($ string)
(push-code! `(load-string ,x)))
((symbol? x)
(($ symbol)
(push-code! `(load-symbol ,(symbol->string x))))
((keyword? x)
(push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
((list? x)
(($ keyword)
(push-code! `(load-keyword
,(symbol->string (keyword-dash-symbol x)))))
(($ list)
(for-each dump! x)
(push-code! `(list ,(length x))))
((pair? x)
(($ pair)
(dump! (car x))
(dump! (cdr x))
(push-code! `(cons)))
((vector? x)
(($ vector)
(for-each dump! (vector->list x))
(push-code! `(vector ,(vector-length x))))
(else
(error "Cannot dump:" x)))))
(error "Cannot dump:" x)))))))

33
module/system/vm/backtrace.scm Normal file
View file

@ -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)))))

39
module/system/vm/core.scm
View file

@ -35,36 +35,21 @@
;;;
;;; Loader
;;; High-level procedures
;;;
(define-public (program-bindings prog)
(cond ((program-meta prog) => car)
(else '())))
(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))))
;;;
;;; 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 (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 (vms:time stat) (vector-ref stat 0))
(define-public (vms:clock stat) (vector-ref stat 1))

3
module/system/vm/disasm.scm
View file

@ -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

125
module/system/vm/frame.scm Normal file
View file

@ -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)))))

2
module/system/vm/profile.scm
View file

@ -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 ()

41
module/system/vm/trace.scm
View file

@ -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))))))))
((: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))))
(define (trace-return vm)
(let ((frame (vm-current-frame vm)))
(print-prefix (frame-dynamic-link frame))
(write (car (vm-fetch-stack vm)))
;; (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 (print-prefix frame)
(and-let* ((link (frame-dynamic-link frame)))
(display "| ")
(print-prefix link)))
(define (trace-return vm)
(let ((stack (vm-current-frame-stack vm)))
(print-indent stack)
(write (vm-return-value vm))
(newline)))
(define (print-indent stack)
(cond ((pair? stack) (display "| ") (print-indent (cdr stack)))))

6
src/Makefile.am
View file

@ -6,13 +6,13 @@ guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
lib_LTLIBRARIES = libguilevm.la
libguilevm_la_SOURCES = \
envs.c instructions.c objcodes.c programs.c vm.c \
envs.h instructions.h objcodes.h programs.h vm.h \
envs.c frames.c instructions.c objcodes.c programs.c vm.c \
envs.h frames.h instructions.h objcodes.h programs.h vm.h \
vm_engine.h vm_expand.h
libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c
BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
envs.x instructions.x objcodes.x programs.x vm.x
envs.x frames.x instructions.x objcodes.x programs.x vm.x
INCLUDES = $(GUILE_CFLAGS)
DISTCLEANFILES = $(BUILT_SOURCES)

184
src/frames.c Normal file
View file

@ -0,0 +1,184 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#include <string.h>
#include "frames.h"
scm_bits_t scm_tc16_heap_frame;
SCM
scm_c_make_heap_frame (SCM *fp)
{
struct scm_heap_frame *p =
scm_must_malloc (sizeof (struct scm_heap_frame), "make_heap_frame");
p->fp = fp;
p->program = SCM_UNDEFINED;
p->variables = SCM_UNDEFINED;
p->dynamic_link = SCM_UNDEFINED;
p->external_link = SCM_UNDEFINED;
SCM_RETURN_NEWSMOB (scm_tc16_heap_frame, p);
}
static SCM
heap_frame_mark (SCM obj)
{
struct scm_heap_frame *p = SCM_HEAP_FRAME_DATA (obj);
scm_gc_mark (p->program);
scm_gc_mark (p->variables);
scm_gc_mark (p->dynamic_link);
return p->external_link;
}
/* Scheme interface */
SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_frame_p
{
return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_program
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
return SCM_STACK_FRAME_PROGRAM (SCM_HEAP_FRAME_DATA (frame)->fp);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_local_variables, "frame-local-variables", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_local_variables
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->variables))
{
SCM prog = scm_frame_program (frame);
struct scm_program *pp = SCM_PROGRAM_DATA (prog);
int i, size = pp->nargs + pp->nlocs;
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_STACK_FRAME_VARIABLE (p->fp, i);
}
return p->variables;
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
return scm_long2num ((long) SCM_VM_BYTE_ADDRESS
(SCM_STACK_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_DATA (frame)->fp)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_dynamic_link
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->dynamic_link))
{
SCM *fp = SCM_VM_STACK_ADDRESS (SCM_STACK_FRAME_DYNAMIC_LINK (p->fp));
if (fp)
p->dynamic_link = scm_c_make_heap_frame (fp);
else
p->dynamic_link = SCM_BOOL_F;
}
return p->dynamic_link;
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_external_link
{
struct scm_heap_frame *p;
SCM_VALIDATE_HEAP_FRAME (1, frame);
p = SCM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->external_link))
p->external_link = SCM_STACK_FRAME_EXTERNAL_LINK (p->fp);
return p->external_link;
}
#undef FUNC_NAME
void
scm_init_frames (void)
{
scm_tc16_heap_frame = scm_make_smob_type ("heap_frame", 0);
scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
#ifndef SCM_MAGIC_SNARFER
#include "frames.x"
#endif
}
/*
Local Variables:
c-file-style: "gnu"
End:
*/

126
src/frames.h Normal file
View file

@ -0,0 +1,126 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _SCM_FRAMES_H_
#define _SCM_FRAMES_H_
#include <libguile.h>
#include "config.h"
#include "programs.h"
/*
* VM Address
*/
#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_STACK_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr))
/*
* VM Stack frames
*/
/* Stack frames are allocated on the VM stack as follows:
| | <- fp + bp->nargs + bp->nlocs + 3
+------------------+ = SCM_STACK_FRAME_UPPER_ADDRESS (fp)
| Return address |
| Dynamic link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local varialbe 1 | = SCM_STACK_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_STACK_FRAME_LOWER_ADDRESS (fp)
| |
*/
#define SCM_STACK_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_STACK_FRAME_PROGRAM (fp))->nlocs)
#define SCM_STACK_FRAME_UPPER_ADDRESS(fp) \
(SCM_STACK_FRAME_DATA_ADDRESS (fp) + 3)
#define SCM_STACK_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_STACK_FRAME_RETURN_ADDRESS(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[2]
#define SCM_STACK_FRAME_DYNAMIC_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_STACK_FRAME_EXTERNAL_LINK(fp) SCM_STACK_FRAME_DATA_ADDRESS (fp)[0]
#define SCM_STACK_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_STACK_FRAME_PROGRAM(fp) fp[-1]
/*
* VM Heap frames
*/
struct scm_heap_frame {
SCM *fp;
SCM program;
SCM variables;
SCM dynamic_link;
SCM external_link;
};
extern scm_bits_t scm_tc16_heap_frame;
#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
#define SCM_HEAP_FRAME_DATA(f) ((struct scm_heap_frame *) SCM_SMOB_DATA (f))
#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
#define SCM_HEAP_FRAME_PROGRAM(f) SCM_HEAP_FRAME_DATA (f)->program
#define SCM_HEAP_FRAME_VARIABLES(f) SCM_HEAP_FRAME_DATA (f)->variables
#define SCM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_HEAP_FRAME_DATA (f)->dynamic_link
#define SCM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_HEAP_FRAME_DATA (f)->external_link
extern SCM scm_c_make_heap_frame (SCM *fp);
extern void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

6
src/objcodes.c
View file

@ -194,14 +194,16 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
SCM prog;
size_t size;
char *base;
struct scm_program *p;
SCM_VALIDATE_OBJCODE (1, objcode);
base = SCM_OBJCODE_BASE (objcode);
size = SCM_OBJCODE_SIZE (objcode);
prog = scm_c_make_program (base + 10, size - 10, objcode);
SCM_PROGRAM_NLOCS (prog) = base[8];
SCM_PROGRAM_NEXTS (prog) = base[9];
p = SCM_PROGRAM_DATA (prog);
p->nlocs = base[8];
p->nexts = base[9];
return prog;
}
#undef FUNC_NAME

59
src/programs.c
View file

@ -59,6 +59,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
p->nrest = 0;
p->nlocs = 0;
p->nexts = 0;
p->meta = SCM_BOOL_F;
p->objs = zero_vector;
p->external = SCM_EOL;
p->holder = holder;
@ -78,7 +79,7 @@ scm_c_make_closure (SCM program, SCM external)
{
SCM prog = scm_c_make_program (0, 0, program);
*SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
SCM_PROGRAM_EXTERNAL (prog) = external;
SCM_PROGRAM_DATA (prog)->external = external;
return prog;
}
@ -86,6 +87,7 @@ static SCM
program_mark (SCM obj)
{
struct scm_program *p = SCM_PROGRAM_DATA (obj);
scm_gc_mark (p->meta);
scm_gc_mark (p->objs);
scm_gc_mark (p->external);
return p->holder;
@ -105,19 +107,6 @@ program_free (SCM obj)
return size;
}
static int
program_print (SCM obj, SCM port, scm_print_state *pstate)
{
SCM name = scm_object_property (obj, scm_sym_name);
scm_puts ("#<program ", port);
if (SCM_FALSEP (name))
scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
else
scm_display (name, port);
scm_putc ('>', port);
return 1;
}
static SCM
program_apply (SCM program, SCM args)
{
@ -138,16 +127,41 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_base
{
SCM_VALIDATE_PROGRAM (1, program);
return scm_long2num ((long) SCM_PROGRAM_DATA (program)->base);
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_arity
{
struct scm_program *p;
SCM_VALIDATE_PROGRAM (1, program);
return SCM_LIST4 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)),
SCM_MAKINUM (SCM_PROGRAM_NREST (program)),
SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)),
SCM_MAKINUM (SCM_PROGRAM_NEXTS (program)));
p = SCM_PROGRAM_DATA (program);
return SCM_LIST4 (SCM_MAKINUM (p->nargs),
SCM_MAKINUM (p->nrest),
SCM_MAKINUM (p->nlocs),
SCM_MAKINUM (p->nexts));
}
#undef FUNC_NAME
SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
(SCM program),
"")
#define FUNC_NAME s_scm_program_meta
{
SCM_VALIDATE_PROGRAM (1, program);
return SCM_PROGRAM_DATA (program)->meta;
}
#undef FUNC_NAME
@ -157,7 +171,7 @@ SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
#define FUNC_NAME s_scm_program_objects
{
SCM_VALIDATE_PROGRAM (1, program);
return SCM_PROGRAM_OBJS (program);
return SCM_PROGRAM_DATA (program)->objs;
}
#undef FUNC_NAME
@ -167,7 +181,7 @@ SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
#define FUNC_NAME s_scm_program_external
{
SCM_VALIDATE_PROGRAM (1, program);
return SCM_PROGRAM_EXTERNAL (program);
return SCM_PROGRAM_DATA (program)->external;
}
#undef FUNC_NAME
@ -177,8 +191,8 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
#define FUNC_NAME s_scm_program_bytecode
{
SCM_VALIDATE_PROGRAM (1, program);
return scm_makfromstr (SCM_PROGRAM_BASE (program),
SCM_PROGRAM_SIZE (program), 0);
return scm_makfromstr (SCM_PROGRAM_DATA (program)->base,
SCM_PROGRAM_DATA (program)->size, 0);
}
#undef FUNC_NAME
@ -191,7 +205,6 @@ scm_init_programs (void)
scm_tc16_program = scm_make_smob_type ("program", 0);
scm_set_smob_mark (scm_tc16_program, program_mark);
scm_set_smob_free (scm_tc16_program, program_free);
scm_set_smob_print (scm_tc16_program, program_print);
scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
#ifndef SCM_MAGIC_SNARFER

13
src/programs.h
View file

@ -58,6 +58,7 @@ struct scm_program {
unsigned char nlocs; /* the number of local variables */
unsigned char nexts; /* the number of external variables */
scm_byte_t *base; /* program base address */
SCM meta; /* meta data */
SCM objs; /* constant objects */
SCM external; /* external environment */
SCM holder; /* the owner of bytecode */
@ -69,18 +70,6 @@ extern scm_bits_t scm_tc16_program;
#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_SIZE(x) (SCM_PROGRAM_DATA (x)->size)
#define SCM_PROGRAM_NARGS(x) (SCM_PROGRAM_DATA (x)->nargs)
#define SCM_PROGRAM_NREST(x) (SCM_PROGRAM_DATA (x)->nrest)
#define SCM_PROGRAM_NLOCS(x) (SCM_PROGRAM_DATA (x)->nlocs)
#define SCM_PROGRAM_NEXTS(x) (SCM_PROGRAM_DATA (x)->nexts)
#define SCM_PROGRAM_BASE(x) (SCM_PROGRAM_DATA (x)->base)
#define SCM_PROGRAM_META(x) (SCM_PROGRAM_DATA (x)->meta)
#define SCM_PROGRAM_OBJS(x) (SCM_PROGRAM_DATA (x)->objs)
#define SCM_PROGRAM_LINKS(x) (SCM_PROGRAM_DATA (x)->links)
#define SCM_PROGRAM_EXTERNAL(x) (SCM_PROGRAM_DATA (x)->external)
#define SCM_PROGRAM_HOLDER(x) (SCM_PROGRAM_DATA (x)->holder)
extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
extern SCM scm_c_make_closure (SCM program, SCM external);

146
src/vm.c
View file

@ -40,10 +40,11 @@
* If you do not wish that, delete this exception notice. */
#include <string.h>
#include "instructions.h"
#include "programs.h"
#include "objcodes.h"
#include "envs.h"
#include "frames.h"
#include "instructions.h"
#include "objcodes.h"
#include "programs.h"
#include "vm.h"
/* I sometimes use this for debugging. */
@ -53,119 +54,6 @@
scm_newline (scm_def_errp); \
}
/*
* VM Heap frame
*/
scm_bits_t scm_tc16_vm_heap_frame;
static SCM
make_vm_heap_frame (SCM *fp)
{
struct scm_vm_heap_frame *p =
scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
p->fp = fp;
p->program = SCM_UNDEFINED;
p->variables = SCM_UNDEFINED;
p->dynamic_link = SCM_UNDEFINED;
p->external_link = SCM_UNDEFINED;
SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p);
}
static SCM
vm_heap_frame_mark (SCM obj)
{
struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
scm_gc_mark (p->program);
scm_gc_mark (p->variables);
scm_gc_mark (p->dynamic_link);
return p->external_link;
}
/* Scheme interface */
SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
(SCM obj),
"")
#define FUNC_NAME s_scm_frame_p
{
return SCM_BOOL (SCM_VM_HEAP_FRAME_P (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_program
{
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp);
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_variables
{
struct scm_vm_heap_frame *p;
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
p = SCM_VM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->variables))
{
SCM prog = scm_frame_program (frame);
int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog);
p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
for (i = 0; i < size; i++)
SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (p->fp, i);
}
return p->variables;
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_dynamic_link
{
struct scm_vm_heap_frame *p;
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
p = SCM_VM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->dynamic_link))
{
SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp));
if (fp)
p->dynamic_link = make_vm_heap_frame (fp);
else
p->dynamic_link = SCM_BOOL_F;
}
return p->dynamic_link;
}
#undef FUNC_NAME
SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_external_link
{
struct scm_vm_heap_frame *p;
SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
p = SCM_VM_HEAP_FRAME_DATA (frame);
if (SCM_UNBNDP (p->external_link))
p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp);
return p->external_link;
}
#undef FUNC_NAME
/*
* VM Continuation
@ -303,6 +191,7 @@ make_vm (void)
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
vp->last_frame = SCM_BOOL_F;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
@ -321,8 +210,8 @@ vm_mark (SCM obj)
fp = vp->fp;
while (fp)
{
SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp);
SCM *upper = SCM_STACK_FRAME_UPPER_ADDRESS (fp);
SCM *lower = SCM_STACK_FRAME_LOWER_ADDRESS (fp);
/* Mark intermediate data */
for (; sp >= upper; sp--)
if (SCM_NIMP (*sp))
@ -337,6 +226,7 @@ vm_mark (SCM obj)
/* Mark the options */
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
scm_gc_mark (vp->hooks[i]);
scm_gc_mark (vp->last_frame);
return vp->options;
}
@ -553,7 +443,17 @@ SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
{
SCM_VALIDATE_VM (1, vm);
VM_CHECK_RUNNING (vm);
return make_vm_heap_frame (SCM_VM_DATA (vm)->fp);
return scm_c_make_heap_frame (SCM_VM_DATA (vm)->fp);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
(SCM vm),
"")
#define FUNC_NAME s_scm_vm_last_frame
{
SCM_VALIDATE_VM (1, vm);
return SCM_VM_DATA (vm)->last_frame;
}
#undef FUNC_NAME
@ -593,7 +493,7 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
VM_CHECK_RUNNING (vm);
vp = SCM_VM_DATA (vm);
for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
for (sp = SCM_STACK_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
ls = scm_cons (*sp, ls);
return ls;
}
@ -607,12 +507,10 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
void
scm_init_vm (void)
{
scm_init_frames ();
scm_init_instructions ();
scm_init_programs ();
scm_init_objcodes ();
scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark);
scm_init_programs ();
scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);

71
src/vm.h
View file

@ -44,76 +44,6 @@
#include <libguile.h>
#include "config.h"
#include "programs.h"
/*
* VM Address
*/
#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_STACK_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
#define SCM_VM_MAKE_BYTE_ADDRESS(ptr) SCM_PACK (ptr)
#define SCM_VM_BYTE_ADDRESS(addr) ((scm_byte_t *) SCM_UNPACK (addr))
/*
* VM Stack frame
*/
/*
| | <- fp + bp->nargs + bp->nlocs + 3
+------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| Dynamic link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local varialbe 1 | = SCM_VM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_VM_FRAME_LOWER_ADDRESS (fp)
| |
*/
#define SCM_VM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp)) \
+ SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \
(SCM_VM_FRAME_DATA_ADDRESS (fp) + 3)
#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_VM_FRAME_RETURN_ADDRESS(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[2]
#define SCM_VM_FRAME_DYNAMIC_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_VM_FRAME_EXTERNAL_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[0]
#define SCM_VM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_VM_FRAME_PROGRAM(fp) fp[-1]
/*
* VM Heap frame
*/
struct scm_vm_heap_frame {
SCM *fp;
SCM program;
SCM variables;
SCM dynamic_link;
SCM external_link;
};
extern scm_bits_t scm_tc16_vm_heap_frame;
#define SCM_VM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x)
#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f))
#define SCM_VALIDATE_VM_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_HEAP_FRAME_P)
#define SCM_VM_HEAP_FRAME_PROGRAM(f) SCM_VM_HEAP_FRAME_DATA (f)->program
#define SCM_VM_HEAP_FRAME_VARIABLES(f) SCM_VM_HEAP_FRAME_DATA (f)->variables
#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link
/*
* VM
*/
#define SCM_VM_BOOT_HOOK 0
#define SCM_VM_HALT_HOOK 1
@ -133,6 +63,7 @@ struct scm_vm {
SCM *stack_limit; /* stack limit address */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
SCM options; /* options */
SCM last_frame; /* last frame */
unsigned long time; /* time spent */
unsigned long clock; /* bogos clock */
};

8
src/vm_engine.c
View file

@ -88,7 +88,7 @@ vm_run (SCM vm, SCM program, SCM args)
/* Boot program */
scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
bytes[1] = scm_ilength (args);
bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
program = scm_c_make_program (bytes, 3, SCM_BOOL_T);
/* Initial frame */
@ -167,10 +167,8 @@ vm_run (SCM vm, SCM program, SCM args)
vm_error:
SYNC_ALL ();
scm_ithrow (sym_vm_error,
SCM_LIST4 (sym_vm_run, err_msg, err_args,
scm_vm_current_frame (vm)),
1);
vp->last_frame = scm_vm_current_frame (vm);
scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
}
abort (); /* never reached */

2
src/vm_engine.h
View file

@ -286,7 +286,7 @@ do { \
} \
}
/* See vm.h for the layout of stack frames */
/* See frames.h for the layout of stack frames */
#define NEW_FRAME() \
{ \

43
src/vm_loader.c
View file

@ -109,18 +109,27 @@ VM_DEFINE_LOADER (load_program, "load-program")
{
size_t len;
SCM prog, x;
struct scm_program *p;
FETCH_LENGTH (len);
prog = scm_c_make_program (ip, len, program);
p = SCM_PROGRAM_DATA (prog);
ip += len;
POP (x);
/* init meta data */
if (SCM_CONSP (x))
{
p->meta = x;
POP (x);
}
/* init object table */
x = *sp;
if (SCM_VECTORP (x))
{
SCM_PROGRAM_OBJS (prog) = x;
DROP ();
x = *sp;
p->objs = x;
POP (x);
}
/* init parameters */
@ -131,31 +140,31 @@ VM_DEFINE_LOADER (load_program, "load-program")
if (-128 <= i && i <= 127)
{
/* 8-bit representation */
SCM_PROGRAM_NARGS (prog) = (i >> 6) & 0x03; /* 7-6 bits */
SCM_PROGRAM_NREST (prog) = (i >> 5) & 0x01; /* 5 bit */
SCM_PROGRAM_NLOCS (prog) = (i >> 2) & 0x07; /* 4-2 bits */
SCM_PROGRAM_NEXTS (prog) = i & 0x03; /* 1-0 bits */
p->nargs = (i >> 6) & 0x03; /* 7-6 bits */
p->nrest = (i >> 5) & 0x01; /* 5 bit */
p->nlocs = (i >> 2) & 0x07; /* 4-2 bits */
p->nexts = i & 0x03; /* 1-0 bits */
}
else
{
/* 16-bit representation */
SCM_PROGRAM_NARGS (prog) = (i >> 12) & 0x07; /* 15-12 bits */
SCM_PROGRAM_NREST (prog) = (i >> 11) & 0x01; /* 11 bit */
SCM_PROGRAM_NLOCS (prog) = (i >> 4) & 0x7f; /* 10-04 bits */
SCM_PROGRAM_NEXTS (prog) = i & 0x0f; /* 03-00 bits */
p->nargs = (i >> 12) & 0x07; /* 15-12 bits */
p->nrest = (i >> 11) & 0x01; /* 11 bit */
p->nlocs = (i >> 4) & 0x7f; /* 10-04 bits */
p->nexts = i & 0x0f; /* 03-00 bits */
}
}
else
{
/* Other cases */
sp -= 4;
SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]);
SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]);
SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[4]);
p->nargs = SCM_INUM (sp[0]);
p->nrest = SCM_INUM (sp[1]);
p->nlocs = SCM_INUM (sp[2]);
p->nexts = SCM_INUM (sp[3]);
}
*sp = prog;
PUSH (prog);
NEXT;
}

8
src/vm_system.c
View file

@ -187,8 +187,8 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
#define OBJECT_REF(i) objects[i]
#define OBJECT_SET(i,o) objects[i] = o
#define LOCAL_REF(i) SCM_VM_FRAME_VARIABLE (fp, i)
#define LOCAL_SET(i,o) SCM_VM_FRAME_VARIABLE (fp, i) = o
#define LOCAL_REF(i) SCM_STACK_FRAME_VARIABLE (fp, i)
#define LOCAL_SET(i,o) SCM_STACK_FRAME_VARIABLE (fp, i) = o
#define VARIABLE_REF(v) SCM_CDR (v)
#define VARIABLE_SET(v,o) SCM_SETCDR (v, o)
@ -379,7 +379,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
EXIT_HOOK ();
reinstate_vm_cont (vp, x);
CACHE_REGISTER ();
program = SCM_VM_FRAME_PROGRAM (fp);
program = SCM_STACK_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
NEXT;
}
@ -496,7 +496,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
FREE_FRAME ();
/* Restore the last program */
program = SCM_VM_FRAME_PROGRAM (fp);
program = SCM_STACK_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
external = fp[bp->nargs + bp->nlocs];
PUSH (ret);