summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-08-07 13:11:27 +0200
committerAndy Wingo <wingo@pobox.com>2008-08-07 13:11:27 +0200
commit07e56b27a1841d70e562ac69b9ef9d25d489ceb3 (patch)
tree5953919e3b45e6e3c1f5a472da088a666fd1a96c /module
parent1865ad56804be4da82a6247a868a81648ebe87b3 (diff)
downloadguile-07e56b27a1841d70e562ac69b9ef9d25d489ceb3.tar.gz
big reorg of scheme modules -- e.g. programs.c -> (system vm program)
This reorganization kills the ugly module-export-all hacks in bootstrap.scm and core.scm. In fact, it gets rid of core.scm entirely, breaking out its functionality into separate files. * module/system/vm/trace.scm: * module/system/vm/profile.scm: * module/system/vm/disasm.scm: * module/system/vm/debug.scm: * module/system/vm/conv.scm: * module/system/vm/assemble.scm: * module/system/repl/repl.scm: * module/system/repl/common.scm: * module/system/base/compile.scm: * module/system/repl/command.scm: Update for changes, and fix a bug in procedure-documentation. * module/system/vm/bootstrap.scm: Just call scm_bootstrap_vm, which handles setting load-compiled for us. * module/system/vm/core.scm: Removed, functionality folded into other modules. * module/system/vm/frame.scm: Export the C frame procedures here; also move scheme functions from core.scm here. * module/system/vm/instruction.scm: New file, exports procedures from instructions.c. * module/system/vm/objcode.scm: New file, exports procedures from objcodes.c. * module/system/vm/program.scm: New file, exports procedures from programs.c, and some scheme functions originally from core.scm. * module/system/vm/vm.scm: New file, from vm.c and core.scm. * src/Makefile.am (libguile_vm_la_SOURCES): Add bootstrap.h. * src/bootstrap.h: New file, prototypes scm_bootstrap_vm (), which the scm_init_* functions call. * src/frames.h: * src/frames.c (scm_init_frames): * src/frames.c (scm_bootstrap_frames): * src/vm.h: * src/instructions.h: * src/instructions.c (scm_init_instructions): * src/instructions.c (scm_bootstrap_instructions): * src/objcodes.h: * src/objcodes.c (scm_bootstrap_objcodes): * src/objcodes.c (scm_init_objcodes): * src/programs.h: * src/programs.c (scm_bootstrap_programs): * src/programs.c (scm_init_programs): * src/vm.c (scm_bootstrap_vm): * src/vm.c (scm_init_vm): Call scm_bootstrap_vm() before doing anything in an init function. Bootstrap_vm will call bootstrap_instructions(), etc to initialize types, then set load-compiled to point to load-compiled/vm. * src/vm.c (scm_load_compiled_with_vm): Code to load .go files, if they're present.
Diffstat (limited to 'module')
-rw-r--r--module/system/base/compile.scm4
-rw-r--r--module/system/repl/command.scm6
-rw-r--r--module/system/repl/common.scm2
-rw-r--r--module/system/repl/repl.scm2
-rw-r--r--module/system/vm/assemble.scm7
-rw-r--r--module/system/vm/bootstrap.scm16
-rw-r--r--module/system/vm/conv.scm4
-rw-r--r--module/system/vm/core.scm185
-rw-r--r--module/system/vm/debug.scm3
-rw-r--r--module/system/vm/disasm.scm4
-rw-r--r--module/system/vm/frame.scm113
-rw-r--r--module/system/vm/instruction.scm28
-rw-r--r--module/system/vm/objcode.scm26
-rw-r--r--module/system/vm/profile.scm2
-rw-r--r--module/system/vm/program.scm63
-rw-r--r--module/system/vm/trace.scm2
-rw-r--r--module/system/vm/vm.scm62
17 files changed, 296 insertions, 233 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 0cc8f1c22..8a08c5a25 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -24,8 +24,8 @@
:use-module (system base language)
:use-module (system il compile)
:use-module (system il glil)
- :use-module ((system vm core)
- :select (the-vm vm-load objcode->u8vector load-objcode))
+ :use-module (system vm objcode)
+ :use-module (system vm vm) ;; for compile-time evaluation
:use-module (system vm assemble)
:use-module (ice-9 regex)
:export (syntax-error compile-file load-source-file load-file
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index fecea4458..f3bccec76 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -24,7 +24,9 @@
:use-module (system base pmatch)
:use-module (system base compile)
:use-module (system repl common)
- :use-module (system vm core)
+ :use-module (system vm objcode)
+ :use-module (system vm program)
+ :use-module (system vm vm)
:autoload (system base language) (lookup-language)
:autoload (system il glil) (pprint-glil)
:autoload (system vm disasm) (disassemble-program disassemble-objcode)
@@ -61,7 +63,7 @@
(lambda (p)
(if (program? p)
(program-documentation p)
- (procedure-documentation p)))))
+ (old-definition p)))))
(define *command-module* (current-module))
(define (command-name c) (car c))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index cbc8bc48e..c142cc177 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -23,7 +23,7 @@
:use-syntax (system base syntax)
:use-module (system base compile)
:use-module (system base language)
- :use-module (system vm core)
+ :use-module (system vm vm)
:export (<repl> make-repl repl-vm repl-language repl-options
repl-tm-stats repl-gc-stats repl-vm-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 5f1a63160..f00f9289c 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -26,7 +26,7 @@
:use-module (system base language)
:use-module (system repl common)
:use-module (system repl command)
- :use-module (system vm core)
+ :use-module (system vm vm)
:use-module (system vm debug)
:use-module (ice-9 rdelim)
:export (start-repl))
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 897a386af..d121dc52f 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -22,10 +22,9 @@
(define-module (system vm assemble)
:use-syntax (system base syntax)
:use-module (system il glil)
- :use-module ((system vm core)
- :select (instruction? instruction-pops
- make-binding
- bytecode->objcode))
+ :use-module (system vm instruction)
+ :use-module (system vm objcode)
+ :use-module ((system vm program) :select (make-binding))
:use-module (system vm conv)
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
diff --git a/module/system/vm/bootstrap.scm b/module/system/vm/bootstrap.scm
index 785bcad67..6ecd83554 100644
--- a/module/system/vm/bootstrap.scm
+++ b/module/system/vm/bootstrap.scm
@@ -25,15 +25,7 @@
;;; Core procedures
;;;
-(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
-
-(module-export! (current-module)
- (delq! '%module-public-interface
- (hash-fold (lambda (k v d) (cons k d)) '()
- (module-obarray (current-module)))))
-
-;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
-;; and friends.
-(set! load-compiled
- (lambda (file)
- ((the-vm) (objcode->program (load-objcode file)))))
+;; Calling this updates boot-9.scm's `load-compiled' to point to to
+;; scm_load_compiled_with_vm, so future module loads will read .go files
+;; if they are present.
+(dynamic-call "scm_bootstrap_vm" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
index 89993f6a3..ebe72b4fe 100644
--- a/module/system/vm/conv.scm
+++ b/module/system/vm/conv.scm
@@ -20,9 +20,7 @@
;;; Code:
(define-module (system vm conv)
- :use-module ((system vm core)
- :select (instruction? instruction-length
- instruction->opcode opcode->instruction))
+ :use-module (system vm instruction)
:use-module (system base pmatch)
:use-module (ice-9 regex)
:use-module (srfi srfi-4)
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
deleted file mode 100644
index 32e2d6b07..000000000
--- a/module/system/vm/core.scm
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; Guile VM core
-
-;; 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 core)
- :use-module (system vm bootstrap)
- :export (arity:nargs arity:nrest arity:nlocs arity:nexts
- make-binding binding:name binding:extp binding:index
- program-bindings program-sources
- program-properties program-property program-documentation
- frame-arguments frame-local-variables frame-external-variables
- frame-environment
- frame-variable-exists? frame-variable-ref frame-variable-set!
- frame-object-name
- vm-fetch-locals vm-fetch-externals vm-return-value
- vms:time vms:clock vm-load))
-
-;;;
-;;; Core procedures
-;;;
-
-;; FIXME
-(module-re-export! (current-module)
- (hash-fold (lambda (k v d) (cons k d)) '()
- (module-obarray
- (resolve-interface '(system vm bootstrap)))))
-
-
-;;;
-;;; Programs
-;;;
-
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-(define arity:nexts cadddr)
-
-(define (make-binding name extp index)
- (list name extp index))
-
-(define binding:name car)
-(define binding:extp cadr)
-(define binding:index caddr)
-
-(define (program-bindings prog)
- (cond ((program-meta prog) => car)
- (else '())))
-
-(define (program-sources prog)
- (cond ((program-meta prog) => cadr)
- (else '())))
-
-(define (program-properties prog)
- (or (and=> (program-meta prog) cddr)
- '()))
-
-(define (program-property prog prop)
- (assq-ref (program-properties proc) prop))
-
-(define (program-documentation prog)
- (assq-ref (program-properties proc) 'documentation))
-
-
-
-;;;
-;;; Frames
-;;;
-
-(define (frame-arguments frame)
- (let* ((prog (frame-program frame))
- (arity (program-arity prog)))
- (do ((n (+ (arity:nargs arity) -1) (1- n))
- (l '() (cons (frame-local-ref frame n) l)))
- ((< n 0) l))))
-
-(define (frame-local-variables frame)
- (let* ((prog (frame-program frame))
- (arity (program-arity prog)))
- (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
- (l '() (cons (frame-local-ref frame n) l)))
- ((< n 0) l))))
-
-(define (frame-external-variables frame)
- (frame-external-link frame))
-
-(define (frame-external-ref frame index)
- (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
- (list-set! (frame-external-link frame) index val))
-
-(define (frame-binding-ref frame binding)
- (if (binding:extp binding)
- (frame-external-ref frame (binding:index binding))
- (frame-local-ref frame (binding:index binding))))
-
-(define (frame-binding-set! frame binding val)
- (if (binding:extp binding)
- (frame-external-set! frame (binding:index binding) val)
- (frame-local-set! frame (binding:index binding) val)))
-
-(define (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 (frame-lookup-binding frame addr sym)
- (do ((bs (frame-bindings frame addr) (cdr bs)))
- ((or (null? bs) (eq? sym (binding:name (car bs))))
- (and (pair? bs) (car bs)))))
-
-(define (frame-object-binding frame addr obj)
- (do ((bs (frame-bindings frame addr) (cdr bs)))
- ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
- (and (pair? bs) (car bs)))))
-
-(define (frame-environment frame addr)
- (map (lambda (binding)
- (cons (binding:name binding) (frame-binding-ref frame binding)))
- (frame-bindings frame addr)))
-
-(define (frame-variable-exists? frame addr sym)
- (if (frame-lookup-binding frame addr sym) #t #f))
-
-(define (frame-variable-ref frame addr sym)
- (cond ((frame-lookup-binding frame addr sym) =>
- (lambda (binding) (frame-binding-ref frame binding)))
- (else (error "Unknown variable:" sym))))
-
-(define (frame-variable-set! frame addr sym val)
- (cond ((frame-lookup-binding frame addr sym) =>
- (lambda (binding) (frame-binding-set! frame binding val)))
- (else (error "Unknown variable:" sym))))
-
-(define (frame-object-name frame addr obj)
- (cond ((frame-object-binding frame addr obj) => binding:name)
- (else #f)))
-
-
-;;;
-;;; Current status
-;;;
-
-(define (vm-fetch-locals vm)
- (frame-local-variables (vm-this-frame vm)))
-
-(define (vm-fetch-externals vm)
- (frame-external-variables (vm-this-frame vm)))
-
-(define (vm-return-value vm)
- (car (vm-fetch-stack vm)))
-
-
-;;;
-;;; Statistics
-;;;
-
-(define (vms:time stat) (vector-ref stat 0))
-(define (vms:clock stat) (vector-ref stat 1))
-
-
-;;;
-;;; Loader
-;;;
-
-(define (vm-load vm objcode)
- (vm (objcode->program objcode)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cf72df3b7..4d23d7c54 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -21,8 +21,7 @@
(define-module (system vm debug)
:use-syntax (system base syntax)
-;; :use-module ((system vm core)
-;; :select (vm-last-frame-chain vm-backtrace))
+ :use-module (system vm vm)
:use-module (system vm frame)
:use-module (ice-9 format)
:export (vm-debugger vm-backtrace))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 60f2d2542..92c91bf35 100644
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -21,7 +21,8 @@
(define-module (system vm disasm)
:use-module (system base pmatch)
- :use-module (system vm core)
+ :use-module (system vm objcode)
+ :use-module (system vm program)
:use-module (system vm conv)
:use-module (ice-9 regex)
:use-module (ice-9 format)
@@ -102,6 +103,7 @@
(let ((info (object->string (car l))))
(print-info n info #f)))))
+;; FIXME: update for recent meta changes
(define (disassemble-meta meta)
(display "Meta info:\n\n")
(for-each (lambda (data)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 29a612b44..7a09a6275 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -20,12 +20,19 @@
;;; Code:
(define-module (system vm frame)
- :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:))
+ :use-module (system vm program)
:export (frame-number frame-address
- vm-current-frame-chain vm-last-frame-chain
- print-frame print-frame-call))
+ print-frame print-frame-call
+ frame-arguments frame-local-variables frame-external-variables
+ frame-environment
+ frame-variable-exists? frame-variable-ref frame-variable-set!
+ frame-object-name
+ frame-local-ref frame-external-link frame-local-set!
+ frame-return-address frame-program
+ frame-dynamic-link frame?))
+
+(dynamic-call "scm_init_frames" (dynamic-link "libguile-vm"))
-
;;;
;;; Frame chain
;;;
@@ -33,21 +40,15 @@
(define frame-number (make-object-property))
(define frame-address (make-object-property))
-(define (vm-current-frame-chain vm)
- (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm)))
-
-(define (vm-last-frame-chain vm)
- (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm)))
-
(define (make-frame-chain frame addr)
- (let* ((link (vm:frame-dynamic-link frame))
+ (let* ((link (frame-dynamic-link frame))
(chain (if (eq? link #t)
'()
(cons frame (make-frame-chain
- link (vm:frame-return-address frame))))))
+ link (frame-return-address frame))))))
(set! (frame-number frame) (length chain))
(set! (frame-address frame)
- (- addr (program-base (vm:frame-program frame))))
+ (- addr (program-base (frame-program frame))))
chain))
@@ -56,7 +57,7 @@
;;;
(define (print-frame frame)
- (format #t "#~A " (vm:frame-number frame))
+ (format #t "#~A " (frame-number frame))
(print-frame-call frame)
(newline))
@@ -72,12 +73,88 @@
(else (vector (abbrev (vector-ref x 0)) '...))))
(else x)))
(write (abbrev (cons (program-name frame)
- (vm:frame-arguments frame)))))
+ (frame-arguments frame)))))
(define (program-name frame)
- (let ((prog (vm:frame-program frame))
- (link (vm:frame-dynamic-link frame)))
+ (let ((prog (frame-program frame))
+ (link (frame-dynamic-link frame)))
(or (object-property prog 'name)
- (vm:frame-object-name link (1- (vm:frame-address link)) prog)
+ (frame-object-name link (1- (frame-address link)) prog)
(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
prog (module-obarray (current-module))))))
+
+
+;;;
+;;; Frames
+;;;
+
+(define (frame-arguments frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-local-variables frame)
+ (let* ((prog (frame-program frame))
+ (arity (program-arity prog)))
+ (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
+ (l '() (cons (frame-local-ref frame n) l)))
+ ((< n 0) l))))
+
+(define (frame-external-variables frame)
+ (frame-external-link frame))
+
+(define (frame-external-ref frame index)
+ (list-ref (frame-external-link frame) index))
+
+(define (frame-external-set! frame index val)
+ (list-set! (frame-external-link frame) index val))
+
+(define (frame-binding-ref frame binding)
+ (if (binding:extp binding)
+ (frame-external-ref frame (binding:index binding))
+ (frame-local-ref frame (binding:index binding))))
+
+(define (frame-binding-set! frame binding val)
+ (if (binding:extp binding)
+ (frame-external-set! frame (binding:index binding) val)
+ (frame-local-set! frame (binding:index binding) val)))
+
+(define (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 (frame-lookup-binding frame addr sym)
+ (do ((bs (frame-bindings frame addr) (cdr bs)))
+ ((or (null? bs) (eq? sym (binding:name (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-object-binding frame addr obj)
+ (do ((bs (frame-bindings frame addr) (cdr bs)))
+ ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-environment frame addr)
+ (map (lambda (binding)
+ (cons (binding:name binding) (frame-binding-ref frame binding)))
+ (frame-bindings frame addr)))
+
+(define (frame-variable-exists? frame addr sym)
+ (if (frame-lookup-binding frame addr sym) #t #f))
+
+(define (frame-variable-ref frame addr sym)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-ref frame binding)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-variable-set! frame addr sym val)
+ (cond ((frame-lookup-binding frame addr sym) =>
+ (lambda (binding) (frame-binding-set! frame binding val)))
+ (else (error "Unknown variable:" sym))))
+
+(define (frame-object-name frame addr obj)
+ (cond ((frame-object-binding frame addr obj) => binding:name)
+ (else #f)))
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
new file mode 100644
index 000000000..e8b325a7f
--- /dev/null
+++ b/module/system/vm/instruction.scm
@@ -0,0 +1,28 @@
+;;; Guile VM instructions
+
+;; 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 instruction)
+ :export (instruction-list
+ instruction? instruction-length
+ instruction-pops instruction-pushes
+ instruction->opcode opcode->instruction))
+
+(dynamic-call "scm_init_instructions" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
new file mode 100644
index 000000000..a814d5b85
--- /dev/null
+++ b/module/system/vm/objcode.scm
@@ -0,0 +1,26 @@
+;;; Guile VM object code
+
+;; 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 objcode)
+ :export (objcode->u8vector objcode? objcode->program bytecode->objcode
+ load-objcode))
+
+(dynamic-call "scm_init_objcodes" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm
index cfc53fee0..fcbe0e0ba 100644
--- a/module/system/vm/profile.scm
+++ b/module/system/vm/profile.scm
@@ -20,7 +20,7 @@
;;; Code:
(define-module (system vm profile)
- :use-module (system vm core)
+ :use-module (system vm vm)
:use-module (ice-9 format)
:export (vm-profile))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
new file mode 100644
index 000000000..3c08542a6
--- /dev/null
+++ b/module/system/vm/program.scm
@@ -0,0 +1,63 @@
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;; 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 of the License, 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; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm program)
+ :export (arity:nargs arity:nrest arity:nlocs arity:nexts
+ make-binding binding:name binding:extp binding:index
+ program-bindings program-sources
+ program-properties program-property program-documentation
+
+ program-arity program-external-set! program-meta
+ program-bytecode program? program-objects
+ program-base program-external))
+
+(dynamic-call "scm_init_programs" (dynamic-link "libguile-vm"))
+
+(define arity:nargs car)
+(define arity:nrest cadr)
+(define arity:nlocs caddr)
+(define arity:nexts cadddr)
+
+(define (make-binding name extp index)
+ (list name extp index))
+
+(define binding:name car)
+(define binding:extp cadr)
+(define binding:index caddr)
+
+(define (program-bindings prog)
+ (cond ((program-meta prog) => car)
+ (else '())))
+
+(define (program-sources prog)
+ (cond ((program-meta prog) => cadr)
+ (else '())))
+
+(define (program-properties prog)
+ (or (and=> (program-meta prog) cddr)
+ '()))
+
+(define (program-property prog prop)
+ (assq-ref (program-properties proc) prop))
+
+(define (program-documentation prog)
+ (assq-ref (program-properties proc) 'documentation))
+
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 0b028277f..0a0dc38ea 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -21,7 +21,7 @@
(define-module (system vm trace)
:use-syntax (system base syntax)
- :use-module (system vm core)
+ :use-module (system vm vm)
:use-module (system vm frame)
:use-module (ice-9 format)
:export (vm-trace vm-trace-on vm-trace-off))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
new file mode 100644
index 000000000..5fd719ca5
--- /dev/null
+++ b/module/system/vm/vm.scm
@@ -0,0 +1,62 @@
+;;; Guile VM core
+
+;; 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 vm)
+ :use-module (system vm frame)
+ :use-module (system vm objcode)
+ :export (vm? the-vm make-vm vm-version
+ vm:ip vm:sp vm:fp
+
+ vm-load vm-return-value
+
+ vm-option set-vm-option! vm-version
+
+ vm-fetch-locals vm-fetch-externals
+ vm-last-frame vm-this-frame vm-fetch-stack
+ vm-current-frame-chain vm-last-frame-chain
+
+ vm-stats vms:time vms:clock
+
+ vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
+ vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
+
+(define (vm-current-frame-chain vm)
+ (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
+
+(define (vm-last-frame-chain vm)
+ (make-frame-chain (vm-last-frame vm) (vm:ip vm)))
+
+(define (vm-fetch-locals vm)
+ (frame-local-variables (vm-this-frame vm)))
+
+(define (vm-fetch-externals vm)
+ (frame-external-variables (vm-this-frame vm)))
+
+(define (vm-return-value vm)
+ (car (vm-fetch-stack vm)))
+
+(define (vms:time stat) (vector-ref stat 0))
+(define (vms:clock stat) (vector-ref stat 1))
+
+(define (vm-load vm objcode)
+ (vm (objcode->program objcode)))