diff options
author | Andy Wingo <wingo@pobox.com> | 2008-08-07 13:11:27 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-08-07 13:11:27 +0200 |
commit | 07e56b27a1841d70e562ac69b9ef9d25d489ceb3 (patch) | |
tree | 5953919e3b45e6e3c1f5a472da088a666fd1a96c /module | |
parent | 1865ad56804be4da82a6247a868a81648ebe87b3 (diff) | |
download | guile-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.scm | 4 | ||||
-rw-r--r-- | module/system/repl/command.scm | 6 | ||||
-rw-r--r-- | module/system/repl/common.scm | 2 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 2 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 7 | ||||
-rw-r--r-- | module/system/vm/bootstrap.scm | 16 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 4 | ||||
-rw-r--r-- | module/system/vm/core.scm | 185 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 3 | ||||
-rw-r--r-- | module/system/vm/disasm.scm | 4 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 113 | ||||
-rw-r--r-- | module/system/vm/instruction.scm | 28 | ||||
-rw-r--r-- | module/system/vm/objcode.scm | 26 | ||||
-rw-r--r-- | module/system/vm/profile.scm | 2 | ||||
-rw-r--r-- | module/system/vm/program.scm | 63 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 2 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 62 |
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))) |