mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-03 21:44:40 +00:00
parent 296ad2b47f
commit 437a31f454
7 changed files with 0 additions and 1525 deletions
Download patch file Download diff file Expand all files Collapse all files

3
vm/.cvsignore
View file

@ -1,3 +0,0 @@
.cvsignore
Makefile
Makefile.in

14
vm/Makefile.am
View file

@ -1,14 +0,0 @@
vmdatadir = $(datadir)/guile/vm
vmdata_DATA = utils.scm types.scm bytecomp.scm compile.scm shell.scm
noinst_DATA = libvm.so
EXTRA_DIST = $(vmdata_DATA)
CLEANFILES = $(noinst_DATA)
MAINTAINERCLEANFILES = Makefile.in
libvm.so:
$(LN_S) -f ../src/.libs/libguilevm.so ./libvm.so
install-data-local:
rm -f $(vmdatadir)/libvm.so \
&& $(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so

496
vm/bytecomp.scm
View file

@ -1,496 +0,0 @@
;;; bytecomp.scm --- convert an intermediate code to an assemble code
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This file is part of Guile VM.
;; Guile VM 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.
;;
;; Guile VM 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 Guile VM; 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 (vm bytecomp)
:use-module (vm vm)
:use-module (vm utils)
:use-module (vm types)
:export (byte-compile))
(define (byte-compile nreqs restp code)
(vector (byte-header nreqs restp (code-env code))
(byte-finalize (byte-optimize (byte-translate code)))))
;;;
;;; Bytecode header
;;;
(define (byte-header nreqs restp env)
(list->vector (cons* nreqs restp (env-header env))))
;;;
;;; Bytecode translation
;;;
(define (byte-translate code)
(let ((stack '()))
;; push opcode
(define (push-code! . args)
(set! stack (cons args stack)))
(let trans ((code code) (use-stack #f) (tail #t))
(let ((tag (code-tag code))
(env (code-env code))
(args (code-args code)))
;;;
;;; Utilities
;;;
;; push the result into the stack
(define (trans-use-stack code) (trans code #t #f))
;; just set the accumulator
(define (trans-non-stack code) (trans code #f #f))
;; code can be a tail position
(define (trans-tail code) (trans code #f tail))
;; set unspecified when a tail position
(define (unspecified-position) (if tail (push-code! '%load-unspecified)))
;; return here when a tail position
(define (return-position) (if tail (push-code! '%return)))
;; push the result into the stack
(define (push-position) (if use-stack (push-code! '%push)))
;; return or push
(define (return-or-push) (return-position) (push-position))
;;;
;;; Translators
;;;
(define (translate-unspecified)
;; #:unspecified
;; %load-unspecified
(push-code! '%load-unspecified)
(return-or-push))
(define (translate-constant obj)
;; #:constant OBJ
;; %pushc OBJ (if use-stack)
;; %loadc OBJ (if non-stack)
(if use-stack
(push-code! '%pushc obj)
(push-code! '%loadc obj))
(return-position))
(define (translate-local-var name var)
(let* ((offset (env-variable-address env var))
(abbrev (string->symbol (format #f "~A:~A" name offset))))
(if (instruction-name? abbrev)
(push-code! abbrev)
(push-code! name offset))))
(define (translate-external-var name var)
(let* ((addr (env-variable-address env var))
(depth (car addr))
(offset (cdr addr))
(abbrev1 (string->symbol
(format #f "~A:~A" name depth)))
(abbrev2 (string->symbol
(format #f "~A:~A:~A" name depth offset))))
(cond ((instruction-name? abbrev2) (push-code! abbrev2))
((instruction-name? abbrev1) (push-code! abbrev1 offset))
(else (push-code! name addr)))))
(define (translate-top-level-var name var)
(push-code! name (variable-name var)))
(define (translate-ref var)
(assert variable? var)
(cond
((local-variable? var)
;; #:ref #<vm:local-var>
;; %pushl OFFSET (if use-stack)
;; %loadl OFFSET (if non-stack)
(translate-local-var (if use-stack '%pushl '%loadl) var))
((external-variable? var)
;; #:ref #<vm:external-var>
;; %pushe (DEPTH . OFFSET) (if use-stack)
;; %loade (DEPTH . OFFSET) (if non-stack)
(translate-external-var (if use-stack '%pushe '%loade) var))
((top-level-variable? var)
;; #:ref #<vm:top-level-var>
;; %pusht SYMBOL (if use-stack)
;; %loadt SYMBOL (if non-stack)
(translate-top-level-var (if use-stack '%pusht '%loadt) var)))
(return-position))
(define (translate-set var obj)
(assert variable? var)
(trans-non-stack obj)
(cond
((local-variable? var)
;; #:set #<vm:local-var> OBJ
;; OBJ
;; %savel OFFSET
;; %name NAME
(translate-local-var '%savel var))
((external-variable? var)
;; #:set #<vm:external-var> OBJ
;; OBJ
;; %savee (DEPTH . OFFSET)
;; %name NAME
(translate-external-var '%savee var))
((top-level-variable? var)
;; #:set #<vm:top-level-var> OBJ
;; OBJ
;; %savet SYMBOL
;; %name NAME
(translate-top-level-var '%savet var)))
;; FIXME: Giving name to every objects is bad, but
;; FIXME: this is useful for debugging.
(push-code! '%name (variable-name var))
(unspecified-position)
(return-or-push))
(define (translate-and . args)
;; #:and ARG1 ARG2... LAST
;; ARG1
;; %br-if-not L0
;; ARG2
;; %br-if-not L0
;; ...
;; LAST
;; L0:
(assert-for-each code? args)
(let* ((list (reverse args))
(last (car list))
(args (reverse! (cdr list))))
(let ((L0 (make-label)))
(for-each (lambda (arg)
(trans-non-stack arg)
(push-code! '%br-if-not L0))
args)
(trans-tail last)
(push-code! #:label L0)))
(return-or-push))
(define (translate-or . args)
;; #:or ARG1 ARG2... LAST
;; ARG1
;; %br-if L0
;; ARG2
;; %br-if L0
;; ...
;; LAST
;; L0:
(assert-for-each code? args)
(let* ((list (reverse args))
(last (car list))
(args (reverse! (cdr list))))
(let ((L0 (make-label)))
(for-each (lambda (arg)
(trans-non-stack arg)
(push-code! '%br-if L0))
args)
(trans-tail last)
(push-code! #:label L0)))
(return-or-push))
(define (translate-program nreqs restp code)
;; #:make-program NREQS RESTP CODE
;; %make-program BYTECODE
(push-code! '%make-program (byte-compile nreqs restp code))
(return-or-push))
(define (translate-label label)
;; #:label is processed by byte-finalize
(assert label? label)
(push-code! #:label label))
(define (translate-goto label)
;; #:goto LABEL
;; %jump ADDR (calculated in byte-finalize)
(assert label? label)
(push-code! '%jump label))
(define (translate-if test then else)
;; #:if TEST THEN ELSE
;; TEST
;; %br-if-not L1
;; THEN (tail position)
;; %jump L2 (if not tail)
;; L1: ELSE (tail position)
;; L2:
(assert code? test)
(assert code? then)
(assert code? else)
(let ((L1 (make-label))
(L2 (make-label)))
(trans-non-stack test)
(push-code! '%br-if-not L1)
(trans-tail then)
(if (not tail)
(push-code! '%jump L2))
(push-code! #:label L1)
(trans-tail else)
(push-code! #:label L2))
(push-position))
(define (translate-until test . body)
;; #:until TEST BODY...
;; L0: TEST
;; %br-if L1
;; BODY...
;; %jump L0
;; L1:
(assert code? test)
(assert-for-each code? body)
(let ((L0 (make-label))
(L1 (make-label)))
(push-code! #:label L0)
(trans-non-stack test)
(push-code! '%br-if L1)
(for-each trans-non-stack body)
(push-code! '%jump L0)
(push-code! #:label L1))
(unspecified-position)
(return-position))
(define (translate-begin . body)
;; #:begin BODY... TAIL
;; BODY...
;; TAIL (tail position)
(assert-for-each code? body)
(let* ((list (reverse body))
(tail (car list))
(body (reverse! (cdr list))))
(for-each trans-non-stack body)
(trans-tail tail))
(push-position))
(define (translate-regular-call code . args)
;; #:call CODE ARGS...
;; ARGS... (-> stack)
;; CODE
;; %(tail-)call NARGS
(let ((nargs (length args)))
(for-each trans-use-stack args)
(trans-non-stack code)
(if tail
(push-code! '%tail-call nargs)
(push-code! '%call nargs)))
(push-position))
(define (translate-function-call inst . args)
;; #:call INST ARGS...
(let ((name (instruction-name inst))
(nargs (length args)))
(cond
((cadr (instruction-arity inst))
;; ARGS... (-> stack)
;; INST NARGS
(for-each trans-use-stack args)
(push-code! name nargs))
(else
(case nargs
((0)
;; INST
(push-code! name))
((1)
;; ARG1
;; INST
(trans-non-stack (car args))
(push-code! name))
((2)
;; ARG1 (-> stack)
;; ARG2
;; INST
(trans-use-stack (car args))
(trans-non-stack (cadr args))
(push-code! name))
((3)
;; ARG1 (-> stack)
;; ARG2 (-> stack)
;; ARG3
;; INST
(trans-use-stack (car args))
(trans-use-stack (cadr args))
(trans-non-stack (caddr args))
(push-code! name))))))
(return-or-push))
(define (translate-call obj . args)
(assert-for-each code? args)
(if (variable? obj)
(if (eq? (variable-type obj) 'function)
(cond
((and (variable-bound? obj)
(and-let* ((obj (variable-value obj))
(def (assq-ref *vm-function-table* obj)))
(or (list-ref def (min (length args) 4))
(error "Wrong number of arguments"))))
=> (lambda (inst)
(apply translate-function-call inst args)))
((top-level-variable? obj)
(apply translate-regular-call
(make-code #:ref env obj) args)))
(apply translate-regular-call
(make-code #:ref env obj) args))
(apply translate-regular-call obj args)))
;;;
;;; Dispatch
;;;
(case tag
((#:unspecified)
;; #:unspecified
(check-nargs args = 0)
(translate-unspecified))
((#:constant)
;; #:constant OBJ
(check-nargs args = 1)
(translate-constant (car args)))
((#:ref)
;; #:ref VAR
(check-nargs args = 1)
(translate-ref (car args)))
((#:set)
;; #:set VAR OBJ
(check-nargs args = 2)
(translate-set (car args) (cadr args)))
((#:and)
;; #:and ARGS...
(apply translate-and args))
((#:or)
;; #:or ARGS...
(apply translate-or args))
((#:make-program)
;; #:make-program NREQS RESTP CODE
(check-nargs args = 3)
(translate-program (car args) (cadr args) (caddr args)))
((#:label)
;; #:label LABEL
(check-nargs args = 1)
(translate-label (car args)))
((#:goto)
;; #:goto LABEL
(check-nargs args = 1)
(translate-goto (car args)))
((#:if)
;; #:if TEST THEN ELSE
(check-nargs args = 3)
(translate-if (car args) (cadr args) (caddr args)))
((#:until)
;; #:until TEST BODY...
(check-nargs args >= 2)
(apply translate-until (car args) (cdr args)))
((#:begin)
;; #:begin BODY...
(check-nargs args >= 1)
(apply translate-begin args))
((#:call)
;; #:call OBJ ARGS...
(check-nargs args >= 1)
(apply translate-call (car args) (cdr args)))
(else
(error "Unknown tag:" tag)))))
;; that's it for this stage
(reverse! stack)))
;;;
;;; Bytecode optimization
;;;
(define (byte-optimize code)
(let loop ((last (car code)) (code (cdr code)) (result '()))
(define (continue) (loop (car code) (cdr code) (cons last result)))
(if (null? code)
(reverse! (cons last result))
(let ((this (car code)))
(case (car this)
((%br-if)
(case (car last)
((null?)
(loop (cons '%br-if-null (cdr this)) (cdr code) result))
(else
(continue))))
((%br-if-not)
(case (car last)
((null?)
(loop (cons '%br-if-not-null (cdr this)) (cdr code) result))
(else
(continue))))
(else
(continue)))))))
;;;
;;; Bytecode finalization
;;;
(define (byte-finalize code)
(let loop ((code code) (result '()))
(cond
((null? code)
;; Return the final assemble code
(let ((finalize (lambda (obj)
(if (label? obj)
(label-position obj)
obj))))
(list->vector (reverse! (map finalize result)))))
((eq? (caar code) #:label)
;; Calculate the label position
(set! (label-position (cadar code)) (length result))
(loop (cdr code) result))
(else
;; Append to the result
(loop (cdr code) (append! (reverse! (car code)) result))))))
;;;
;;; Function table
;;;
(define (functional-instruction-alist)
(let ((alist '()))
(define (add! name inst)
(let ((pair (assq name alist)))
(if pair
(set-cdr! pair (cons inst (cdr pair)))
(set! alist (acons name (list inst) alist)))))
(for-each (lambda (inst)
(and-let* ((name (instruction-scheme-name inst)))
(add! name inst)))
(instruction-list))
alist))
(define (build-table-data pair)
(let ((name (car pair)) (insts (cdr pair)))
(let ((vec (make-vector 5 #f)))
(define (build-data! inst)
(let ((arity (instruction-arity inst)))
(let ((nargs (car arity))
(restp (cadr arity)))
(if restp
(do ((i nargs (1+ i)))
((>= i 4)
(vector-set! vec 4 inst))
(if (not (vector-ref vec i))
(vector-set! vec i inst)))
(vector-set! vec nargs inst)))))
(for-each build-data! insts)
(let ((func (eval name (interaction-environment))))
(cons func (vector->list vec))))))
(define *vm-function-table*
(map build-table-data (functional-instruction-alist)))
;;; bytecomp.scm ends here

311
vm/compile.scm
View file

@ -1,311 +0,0 @@
;;; compile.scm --- Compile Scheme codes
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This file is part of Guile VM.
;; Guile VM 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.
;;
;; Guile VM 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 Guile VM; 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 (vm compile)
:use-module (vm vm)
:use-module (vm utils)
:use-module (vm types)
:use-module (vm bytecomp)
:use-module (ice-9 syncase)
:export (compile compile-file))
(define (compile form . opts)
(catch 'result
(lambda ()
(let ((x (syncase form)))
(if (or (memq #:e opts) (memq #:expand-only opts))
(throw 'result x))
(set! x (parse x (make-env '() (make-top-level-env))))
(if (or (memq #:p opts) (memq #:parse-only opts))
(throw 'result x))
(set! x (byte-compile 0 #f x))
(if (or (memq #:c opts) (memq #:compile-only opts))
(throw 'result x))
(make-program (make-bytecode x) #f)))
(lambda (key arg) arg)))
(define (compile-file file)
(let ((out-file (string-append (substring file 0 (1- (string-length file)))
"c")))
(with-input-from-file file
(lambda ()
(with-output-to-file out-file
(lambda ()
(format #t ";;; Compiled from ~A\n\n" file)
(display "(use-modules (vm vm))\n\n")
(display "(let ((vm (make-vm)))\n")
(display "(define (vm-exec code)")
(display "(vm-run vm (make-program (make-bytecode code) #f)))\n")
(do ((input (read) (read)))
((eof-object? input))
(display "(vm-exec ")
(write (compile input #:compile-only))
(display ")\n"))
(display ")\n")))))))
;;;
;;; Parser
;;;
(define (parse x env)
(cond ((pair? x) (parse-pair x env))
((symbol? x) (make-code:ref env (env-ref env x)))
(else (make-code:constant env x))))
(define (parse-pair x env)
(let ((name (car x)) (args (cdr x)))
(if (assq name *syntax-alist*)
;; syntax
((assq-ref *syntax-alist* name) args env)
;; procedure
(let ((proc (if (symbol? name)
(env-ref env name)
(parse name env))))
(if (and (variable? proc)
(variable-bound? proc)
(assq (variable-value proc) *procedure-alist*))
;; procedure macro
((assq-ref *procedure-alist* (variable-value proc)) args env)
;; procedure call
(apply make-code:call env proc (map-parse args env)))))))
(define (map-parse x env)
(map (lambda (x) (parse x env)) x))
;;;
;;; Syntax
;;;
(define *syntax-list*
'(quote lambda set! define if cond and or begin let let* letrec
local-set! until))
(define (parse-quote args env)
(make-code:constant env (car args)))
(define (canon-formals formals)
;; foo -> (), foo
;; (foo bar baz) -> (foo bar baz), #f
;; (foo bar . baz) -> (foo bar), baz
(cond ((symbol? formals)
(values '() formals))
((or (null? formals)
(null? (cdr (last-pair formals))))
(values formals #f))
(else
(let* ((copy (list-copy formals))
(pair (last-pair copy))
(last (cdr pair)))
(set-cdr! pair '())
(values copy last)))))
(define (parse-lambda args env)
(let ((formals (car args)) (body (cdr args)))
(call-with-values (lambda () (canon-formals formals))
(lambda (reqs rest)
(let* ((syms (append reqs (if rest (list rest) '())))
(new-env (make-env syms env)))
(make-code:program env (length reqs) (if rest #t #f)
(parse-begin body new-env)))))))
(define (parse-set! args env)
(let ((var (env-ref env (car args)))
(val (parse (cadr args) env)))
(variable-externalize! var)
(make-code:set env var val)))
(define (parse-local-set! args env)
(let ((var (env-ref env (car args)))
(val (parse (cadr args) env)))
(make-code:set env var val)))
(define (parse-define args env)
(parse-set! args env))
(define (parse-if args env)
(let ((test (parse (car args) env))
(consequent (parse (cadr args) env))
(alternate (if (null? (cddr args))
(make-code:unspecified env)
(parse (caddr args) env))))
(make-code:if env test consequent alternate)))
;; FIXME: This should be expanded by syncase.
(define (parse-cond args env)
(cond ((null? args) (make-code:unspecified env))
((eq? (caar args) 'else)
(parse-begin (cdar args) env))
(else
(let* ((clause (car args))
(test (parse (car clause) env))
(body (parse-begin (cdr clause) env))
(alternate (parse-cond (cdr args) env)))
(make-code:if env test body alternate)))))
(define (parse-and args env)
(apply make-code:and env (map-parse args env)))
(define (parse-or args env)
(apply make-code:or env (map-parse args env)))
(define (parse-begin args env)
(apply make-code:begin env (map-parse args env)))
(define (%parse-let:finish env bindings init body)
(for-each (lambda (binding)
(env-remove-variable! env (car binding)))
bindings)
(apply make-code:begin env (append! init body)))
(define (parse-let args env)
(if (symbol? (car args))
;; named let
(let ((tag (car args)) (bindings (cadr args)) (body (cddr args)))
(let* ((var (env-add-variable! env tag))
(proc (parse-lambda (cons (map car bindings) body) env))
(init (make-code:set env var proc))
(call (apply make-code:call env var
(map-parse (map cadr bindings) env))))
(env-remove-variable! env tag)
(make-code:begin env init call)))
;; normal let
(let ((bindings (car args)) (body (cdr args)))
(let* (;; create values before binding
(vals (map-parse (map cadr bindings) env))
;; create bindings
(init (map (lambda (sym val)
(let ((var (env-add-variable! env sym)))
(make-code:set env var val)))
(map car bindings) vals)))
(%parse-let:finish env bindings init (map-parse body env))))))
(define (parse-let* args env)
(let ((bindings (car args)) (body (cdr args)))
(let (;; create values and bindings one after another
(init (map (lambda (binding)
(let* ((val (parse (cadr binding) env))
(var (env-add-variable! env (car binding))))
(make-code:set env var val)))
bindings)))
(%parse-let:finish env bindings init (map-parse body env)))))
(define (parse-letrec args env)
(let ((bindings (car args)) (body (cdr args)))
(let* (;; create all variables before values
(vars (map (lambda (sym)
(env-add-variable! env sym))
(map car bindings)))
;; create and set values
(init (map (lambda (var val)
(make-code:set env var (parse val env)))
vars (map cadr bindings))))
(%parse-let:finish env bindings init (map-parse body env)))))
(define (parse-until args env)
(apply make-code:until env (parse (car args) env)
(map-parse (cdr args) env)))
(define *syntax-alist*
(map (lambda (name)
(cons name (eval (symbol-append 'parse- name) (current-module))))
*syntax-list*))
;;;
;;; Procedure
;;;
(define *procedure-list*
'(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
;;map for-each
))
(define (parse-caar args env) (parse `(car (car ,@args)) env))
(define (parse-cadr args env) (parse `(car (cdr ,@args)) env))
(define (parse-cdar args env) (parse `(cdr (car ,@args)) env))
(define (parse-cddr args env) (parse `(cdr (cdr ,@args)) env))
(define (parse-caaar args env) (parse `(car (car (car ,@args))) env))
(define (parse-caadr args env) (parse `(car (car (cdr ,@args))) env))
(define (parse-cadar args env) (parse `(car (cdr (car ,@args))) env))
(define (parse-caddr args env) (parse `(car (cdr (cdr ,@args))) env))
(define (parse-cdaar args env) (parse `(cdr (car (car ,@args))) env))
(define (parse-cdadr args env) (parse `(cdr (car (cdr ,@args))) env))
(define (parse-cddar args env) (parse `(cdr (cdr (car ,@args))) env))
(define (parse-cdddr args env) (parse `(cdr (cdr (cdr ,@args))) env))
(define (parse-caaaar args env) (parse `(car (car (car (car ,@args)))) env))
(define (parse-caaadr args env) (parse `(car (car (car (cdr ,@args)))) env))
(define (parse-caadar args env) (parse `(car (car (cdr (car ,@args)))) env))
(define (parse-caaddr args env) (parse `(car (car (cdr (cdr ,@args)))) env))
(define (parse-cadaar args env) (parse `(car (cdr (car (car ,@args)))) env))
(define (parse-cadadr args env) (parse `(car (cdr (car (cdr ,@args)))) env))
(define (parse-caddar args env) (parse `(car (cdr (cdr (car ,@args)))) env))
(define (parse-cadddr args env) (parse `(car (cdr (cdr (cdr ,@args)))) env))
(define (parse-cdaaar args env) (parse `(cdr (car (car (car ,@args)))) env))
(define (parse-cdaadr args env) (parse `(cdr (car (car (cdr ,@args)))) env))
(define (parse-cdadar args env) (parse `(cdr (car (cdr (car ,@args)))) env))
(define (parse-cdaddr args env) (parse `(cdr (car (cdr (cdr ,@args)))) env))
(define (parse-cddaar args env) (parse `(cdr (cdr (car (car ,@args)))) env))
(define (parse-cddadr args env) (parse `(cdr (cdr (car (cdr ,@args)))) env))
(define (parse-cdddar args env) (parse `(cdr (cdr (cdr (car ,@args)))) env))
(define (parse-cddddr args env) (parse `(cdr (cdr (cdr (cdr ,@args)))) env))
;(define (parse-map args env)
; (check-nargs args >= 2)
; (case (length args)
; ((2)
; (let ((proc (car args)) (list (cadr args)))
; (parse `(let ((list ,list) (result '()))
; (until (null? list)
; (local-set! result (cons (,proc (car list)) result))
; (local-set! list (cdr list)))
; (reverse! result))
; env)))
; (else
; (error "Not implemented yet"))))
;
;(define (parse-for-each args env)
; (check-nargs args >= 2)
; (case (length args)
; ((2)
; (let ((proc (car args)) (list (cadr args)))
; (parse `(let ((list ,list))
; (until (null? list)
; (,proc (car list))
; (local-set! list (cdr list))))
; env)))
; (else
; (error "Not implemented yet"))))
(define *procedure-alist*
(map (lambda (name)
(cons (eval name (current-module))
(eval (symbol-append 'parse- name) (current-module))))
*procedure-list*))
;;; compile.scm ends here

221
vm/shell.scm
View file

@ -1,221 +0,0 @@
;;; shell.scm --- interactive VM operations
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This file is part of Guile VM.
;; Guile VM 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.
;;
;; Guile VM 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 Guile VM; 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 (vm shell)
:use-module (vm vm)
:use-module (vm utils)
:use-module (vm compile)
:use-module (ice-9 format))
;;;
;;; VM Shell
;;;
(define *vm-default-prompt* "VM> ")
(define *vm-boot-message* "\
Copyright (C) 2000 Free Software Foundation, Inc.
Guile VM is free software, covered by the GNU General Public License,
and you are welcome to change it and/or distribute copies of it under
certain conditions. There is absolutely no warranty for Guile VM.\n")
(define (vm-init vm)
(vm-set-option! vm 'prompt *vm-default-prompt*)
(vm-set-option! vm 'verbose #f)
(vm-set-option! vm 'history-count 1))
(define-public (vm-boot vm)
(format #t "Guile Virtual Machine ~A\n" (vm-version))
(display *vm-boot-message*)
(display "\nType \"help\" for information\n")
(vm-shell vm))
(define-public (vm-shell vm)
(vm-init vm)
(let ((read-expr (lambda () (read (current-input-port)))))
(let loop ()
(display (or (vm-option vm 'prompt) *vm-default-prompt*))
(let ((cmd (read-expr)))
(if (not (eof-object? cmd))
(case cmd
((eval) (vm-eval vm (read-expr)) (loop))
((trace) (vm-trace vm (read-expr)) (loop))
((parse) (vm-parse vm (read-expr)) (loop))
((compile) (vm-compile vm (read-expr)) (loop))
((set) (vm-set-option! vm (read-expr) (read-expr)) (loop))
(else
(error "Unknown command: ~S" cmd))))))))
(define-public (vm-repl vm)
(vm-init vm)
(let loop ()
(display (or (vm-option vm 'prompt) *vm-default-prompt*))
(let ((form (read (current-input-port))))
(if (not (eof-object? form))
(begin
(vm-eval vm form)
(loop))))))
(define (vm-eval vm form)
(let ((result (vm-run vm (compile form))))
(if (not (eq? result *unspecified*))
(let* ((n (or (vm-option vm 'history-count) 1))
(var (symbol-append "$" (number->string n))))
(intern-symbol #f var)
(symbol-set! #f var result)
(format #t "~A = ~S\n" var result)
(vm-set-option! vm 'history-count (1+ n))
result))))
(define (vm-parse vm form)
(parse form (make-top-level-env)))
(define (vm-compile vm form)
#f)
;;;
;;; Step
;;;
(define (vm-step-boot vm)
(format #t "VM: Starting a program ~S:~%"
(frame-program (vm-current-frame vm))))
(define (vm-step-halt vm)
(display "VM: Program terminated with the return value: ")
(display (vm:ac vm))
(newline))
(define (vm-step-next vm)
(if (vm-option vm 'verbose)
(let ((frame (vm-current-frame vm)))
(display "--------------------------------------------------\n")
(format #t "PC = 0x~X SP = 0x~X FP = 0x~X AC = ~S~%"
(vm:pc vm) (vm:sp vm) (vm:fp vm) (vm:ac vm))
(do ((frame frame (frame-dynamic-link frame))
(frames '() (cons frame frames)))
((not frame)
(for-each (lambda (frame)
(format #t "Frame = [~S 0x~X 0x~X]~%"
(frame-program frame)
(frame-stack-pointer frame)
(frame-return-address frame)))
frames)))
(format #t "Local variables = ~S~%" (frame-variables frame))
(format #t "External variables = ~S~%" (frame-external-link frame))
(format #t "Stack = ~S~%" (vm-stack->list vm))))
(format #t "0x~X:" (vm:pc vm))
(for-each (lambda (obj) (display " ") (write obj))
(vm-fetch-code vm (vm:pc vm)))
(newline))
(define-public (vm-step vm form . opts)
(let ((debug-flag (vm-option vm 'debug)))
(dynamic-wind
(lambda ()
(add-hook! (vm-boot-hook vm) vm-step-boot)
(add-hook! (vm-halt-hook vm) vm-step-halt)
(add-hook! (vm-next-hook vm) vm-step-next)
(vm-set-option! vm 'debug #t))
(lambda ()
(if (pair? opts)
(vm-set-option! vm 'verbose #t))
(vm-run vm (compile form)))
(lambda ()
(remove-hook! (vm-boot-hook vm) vm-step-boot)
(remove-hook! (vm-halt-hook vm) vm-step-halt)
(remove-hook! (vm-next-hook vm) vm-step-next)
(vm-set-option! vm 'debug debug-flag)))))
;;;
;;; Trace
;;;
(define (vm-trace-prefix frame)
(and-let* ((link (frame-dynamic-link frame)))
(display "| ")
(vm-trace-prefix link)))
(define (vm-frame->call frame)
(define (truncate! list n)
(let loop ((list list) (n n))
(if (<= n 1)
(set-cdr! list '())
(loop (cdr list) (1- n))))
list)
(let* ((prog (frame-program frame))
(name (or (name prog) prog)))
(cons name (reverse! (vector->list (frame-variables frame))))))
(define (vm-trace-apply vm)
(let ((frame (vm-current-frame vm)))
(vm-trace-prefix frame)
(display (vm-frame->call frame))
(newline)))
(define (vm-trace-return vm)
(vm-trace-prefix (vm-current-frame vm))
(display (vm:ac vm))
(newline))
(define-public (vm-trace vm form)
(let ((debug-flag (vm-option vm 'debug)))
(dynamic-wind
(lambda ()
(add-hook! (vm-apply-hook vm) vm-trace-apply)
(add-hook! (vm-return-hook vm) vm-trace-return)
(vm-set-option! vm 'debug #t))
(lambda ()
(vm-run vm (compile form)))
(lambda ()
(remove-hook! (vm-apply-hook vm) vm-trace-apply)
(remove-hook! (vm-return-hook vm) vm-trace-return)
(vm-set-option! vm 'debug debug-flag)))))
;;;
;;; Disassemble
;;;
(define-public (disassemble program)
(format #t "Program at ~X:" (program-base program))
(let ((subprogs '())
(list (vector->list (bytecode-decode (program-code program)))))
(for-each (lambda (obj)
(cond ((opcode? obj)
(newline)
(display obj))
((program? obj)
(set! subprogs (cons subprogs obj))
(display " ")
(display obj))
(else
(display " ")
(display obj))))
list)
(newline)
(for-each disassemble (reverse! subprogs))))
;;; shell.scm ends here

374
vm/types.scm
View file

@ -1,374 +0,0 @@
;;; types.scm --- data types used in the compiler and assembler
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This file is part of Guile VM.
;; Guile VM 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.
;;
;; Guile VM 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 Guile VM; 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 (vm types)
:use-module (vm vm)
:use-module (vm utils)
:use-module (oop goops))
;;;
;;; VM code
;;;
(define-class <vm:code> ()
(tag #:accessor code-tag #:init-keyword #:tag)
(env #:accessor code-env #:init-keyword #:env)
(args #:accessor code-args #:init-keyword #:args)
(type #:accessor code-type #:init-value #f))
(export code-tag code-env code-args code-type)
(define-method (write (obj <vm:code>) port)
(display "#<vm:")
(display (keyword->symbol (code-tag obj)))
(map (lambda (obj) (display " ") (write obj port))
(code-args obj))
(display ">"))
(define-public (code? obj)
(is-a? obj <vm:code>))
(define-public (make-code tag env . args)
(assert keyword? tag)
(assert env? env)
(make <vm:code> #:tag tag #:env env #:args args))
;;;
;;; VM label
;;;
(define-class <vm:label> ()
(pos #:accessor label-position))
(export label-position)
(define-public (label? obj)
(is-a? obj <vm:label>))
(define-public (make-label)
(make <vm:label>))
;;;
;;; VM location
;;;
(define-class <vm:location> ())
(define (make-location)
(make <vm:location>))
;;;
;;; VM variable
;;;
(define-class <vm:var> ()
(name #:accessor variable-name #:init-keyword #:name)
(type #:accessor variable-type #:init-value #f)
(value #:accessor variable-value)
(loc #:accessor variable-location #:init-keyword #:location)
(count #:accessor variable-count #:init-value 0))
(define-class <vm:local-var> (<vm:var>))
(define-class <vm:external-var> (<vm:var>))
(define-class <vm:top-level-var> (<vm:var>))
(export variable-name variable-type variable-value variable-count)
(define-method (write (obj <vm:var>) port)
(display "#")
(display (class-name (class-of obj)))
(display " ")
(display (variable-name obj))
(display ">"))
(define-public (make-local-variable name location)
(make <vm:local-var> #:name name #:location location))
(define-public (make-top-level-variable name)
(make <vm:top-level-var> #:name name))
(define-public (variable? obj)
(is-a? obj <vm:var>))
(define-public (local-variable? obj)
(is-a? obj <vm:local-var>))
(define-public (external-variable? obj)
(is-a? obj <vm:external-var>))
(define-public (top-level-variable? obj)
(is-a? obj <vm:top-level-var>))
(define-public (variable-bound? var)
(assert variable? var)
(slot-bound? var 'value))
(define-public (variable-externalize! var)
(assert variable? var)
(if (local-variable? var)
(change-class var <vm:external-var>)))
;;;
;;; VM environment
;;;
(define-class <vm:env> ()
(space #:accessor env-name-space #:init-value '())
(args #:accessor env-arguments #:init-keyword #:args)
(vars #:accessor env-variables #:init-value '())
(locs #:accessor env-locations #:init-value '())
(exts #:accessor env-externals #:init-value #f)
(link #:accessor env-external-link #:init-keyword #:link))
(define-public (make-env syms link)
(let* ((syms (reverse syms))
(args (map (lambda (sym)
(make-local-variable sym (make-location)))
syms))
(env (make <vm:env> #:args args #:link link)))
(for-each (lambda (sym var)
(set! (env-name-space env)
(acons sym var (env-name-space env))))
syms args)
env))
(define-public (make-top-level-env)
(make-env '() #f))
(define-public (env? obj) (is-a? obj <vm:env>))
(define-public (top-level-env? obj)
(and (env? obj) (not (env-external-link obj))))
(define-public (env-finalized? env)
(if (env-externals env) #t #f))
(define-public (env-add-variable! env sym)
(assert env? env)
(assert symbol? sym)
(if (env-finalized? env)
(error "You may not add a variable after finalization"))
(let ((var (if (top-level-env? env)
(make-top-level-variable sym)
(let* ((locs (env-locations env))
(loc (if (null? locs)
(make-location)
(begin
(set! (env-locations env) (cdr locs))
(car locs)))))
(make-local-variable sym loc)))))
(set! (env-name-space env) (acons sym var (env-name-space env)))
(set! (env-variables env) (cons var (env-variables env)))
var))
(define-public (env-remove-variable! env sym)
(assert env? env)
(assert symbol? sym)
(if (env-finalized? env)
(error "You may not remove a variable after finalization"))
(let ((var (assq-ref (env-name-space env) sym)))
(if (not var)
(error "No such variable: ~A\n" sym))
(if (local-variable? var)
(set! (env-locations env)
(cons (variable-location var) (env-locations env))))
(set! (env-name-space env)
(delq! (assq sym (env-name-space env)) (env-name-space env)))
var))
;; Find a varialbe in the environment
(define-public (env-ref env sym)
(assert env? env)
(assert symbol? sym)
(if (env-finalized? env)
(error "You may not find a variable after finalization"))
(or (env-local-ref env sym)
(env-external-ref env sym)
(env-top-level-ref env sym)
(error "No way!")))
(define (env-local-ref env sym)
(if (assq sym (env-name-space env))
(let ((var (assq-ref (env-name-space env) sym)))
(set! (variable-count var) (1+ (variable-count var)))
var)
#f))
(define (env-external-ref env sym)
(let ((ext-env (env-external-link env)))
(if (not ext-env)
#f
(let ((var (env-local-ref ext-env sym)))
(if var
(begin
(variable-externalize! var)
var)
(env-external-ref ext-env sym))))))
(define (env-top-level-ref env sym)
(let ((var (make-top-level-variable sym)))
(if (defined? sym)
;; Get the value in the top-level
(let ((obj (eval sym (interaction-environment))))
(set! (variable-value var) obj)
(set! (variable-type var)
(cond ((macro? obj) 'macro)
((program? obj) 'program)
((procedure? obj) 'function)
(else #f)))))
var))
;; Finalization
(define-public (env-finalize! env)
(if (not (env-finalized? env))
(let ((locs (uniq! (map variable-location
(append (filter local-variable?
(env-variables env))
(env-arguments env)))))
(exts (filter external-variable?
(append (env-variables env) (env-arguments env)))))
(set! (env-locations env) locs)
(set! (env-externals env) (reverse! exts)))))
(define-public (env-header env)
(env-finalize! env)
(let ((nvars (length (uniq! (map variable-location
(filter local-variable?
(env-variables env))))))
(nexts (length (env-externals env)))
(exts (list->vector
(map (lambda (var)
(env-local-variable-address env var))
(filter external-variable?
(reverse (env-arguments env)))))))
(list nvars nexts exts)))
(define (get-offset obj list)
(- (length list) (length (memq obj list))))
(define-public (env-variable-address env var)
(env-finalize! env)
(cond ((local-variable? var)
(env-local-variable-address env var))
((external-variable? var)
(env-external-variable-address env var))
(else
(error "Wrong type argument: ~S" var))))
(define (env-local-variable-address env var)
(get-offset (variable-location var) (env-locations env)))
(define (env-external-variable-address env var)
(let loop ((depth 0) (env env))
(let ((list (env-externals env)))
(cond ((null? list)
(loop depth (env-external-link env)))
((memq var list)
(cons depth (get-offset var list)))
(else (loop (1+ depth) (env-external-link env)))))))
;;;
;;; Intermediate codes
;;;
(define-public (make-code:unspecified env)
(assert env? env)
(make-code #:unspecified env))
(define-public (make-code:constant env obj)
(assert env? env)
(make-code #:constant env obj))
(define-public (make-code:ref env var)
(assert env? env)
(assert variable? var)
(let ((code (make-code #:ref env var)))
(set! (code-type code) (variable-type var))
code))
(define-public (make-code:set env var val)
(assert env? env)
(assert variable? var)
(assert code? val)
(let ((code (make-code #:set env var val)))
(set! (variable-type var) (code-type val))
(set! (code-type code) (variable-type var))
code))
(define-public (make-code:program env nreqs restp body)
(assert env? env)
(assert integer? nreqs)
(assert boolean? restp)
(assert code? body)
(let ((code (make-code #:make-program env nreqs restp body)))
(set! (code-type code) 'program)
code))
(define-public (make-code:call env proc . args)
(assert env? env)
(assert (lambda (x) (or (variable? x) (code? x))) proc)
(assert-for-each code? args)
(apply make-code #:call env proc args))
(define-public (make-code:if env test consequent alternate)
(assert env? env)
(assert code? test)
(assert code? consequent)
(assert code? alternate)
(let ((code (make-code #:if env test consequent alternate)))
(if (eq? (code-type consequent) (code-type alternate))
(set! (code-type code) (code-type consequent)))
code))
(define-public (make-code:and env . args)
(assert env? env)
(assert-for-each code? args)
(apply make-code #:and env args))
(define-public (make-code:or env . args)
(assert env? env)
(assert-for-each code? args)
(apply make-code #:or env args))
(define-public (make-code:begin env . body)
(assert env? env)
(assert-for-each code? body)
(let ((code (apply make-code #:begin env body)))
(set! (code-type code) (code-type (last body)))
code))
(define-public (make-code:until env test . body)
(assert env? env)
(assert code? test)
(assert-for-each code? body)
(apply make-code #:until env test body))
;;; types.scm ends here

106
vm/utils.scm
View file

@ -1,106 +0,0 @@
;;; utils.scm ---
;; Copyright (C) 2000 Free Software Foundation, Inc.
;; This file is part of Guile VM.
;; Guile VM 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.
;;
;; Guile VM 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 Guile VM; 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 (vm utils)
:use-module (ice-9 and-let*)
:use-module (ice-9 format))
(export and-let*)
(define-public (assert predicate obj)
(if (not (predicate obj))
(scm-error 'wrong-type-arg #f
"Wrong type argument: ~S, ~S"
(list (procedure-name predicate) obj) #f)))
(define-public (assert-for-each predicate list)
(for-each (lambda (x) (assert predicate x)) list))
(define-public (check-nargs args pred n)
(if (not (pred (length args) n))
(error "Too many or few arguments")))
(define-public (last list)
(car (last-pair list)))
(define-public (rassq key alist)
(let loop ((alist alist))
(cond ((null? alist) #f)
((eq? key (cdar alist)) (car alist))
(else (loop (cdr alist))))))
(define-public (rassq-ref alist key)
(let ((obj (rassq key alist)))
(if obj (car obj) #f)))
(define-public (map-if pred func list)
(let loop ((list list) (result '()))
(if (null? list)
(reverse! result)
(if (pred (car list))
(loop (cdr list) (cons (func (car list)) result))
(loop (cdr list) result)))))
(define-public (map-tree func tree)
(cond ((null? tree) '())
((pair? tree)
(cons (map-tree func (car tree)) (map-tree func (cdr tree))))
(else (func tree))))
(define-public (filter pred list)
(let loop ((list list) (result '()))
(if (null? list)
(reverse! result)
(if (pred (car list))
(loop (cdr list) (cons (car list) result))
(loop (cdr list) result)))))
(define-public (uniq! list)
(do ((rest list (begin (set-cdr! rest (delq! (car rest) (cdr rest)))
(cdr rest))))
((null? rest) list)))
(define-public (finalize obj)
(if (promise? obj) (force obj) obj))
(export time)
(define-macro (time form)
`(let* ((gc-start (gc-run-time))
(tms-start (times))
(result ,form)
(tms-end (times))
(gc-end (gc-run-time))
(get (lambda (proc start end)
(/ (- (proc end) (proc start))
internal-time-units-per-second))))
(display "clock utime stime cutime cstime gc\n")
(format #t "~5a ~5a ~5a ~6a ~6a ~a~%"
(get tms:clock tms-start tms-end)
(get tms:utime tms-start tms-end)
(get tms:stime tms-start tms-end)
(get tms:cutime tms-start tms-end)
(get tms:cstime tms-start tms-end)
(get id gc-start gc-end))
result))
;;; utils.scm ends here