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

big reorg of scheme modules -- e.g. programs.c -> (system vm program)

Browse source 
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.
This commit is contained in:
Andy Wingo 2008-08-07 13:11:27 +02:00
parent 1865ad5680
commit 07e56b27a1
29 changed files with 422 additions and 242 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -24,8 +24,8 @@
:use-module (system base language) :use-module (system base language)
:use-module (system il compile) :use-module (system il compile)
:use-module (system il glil) :use-module (system il glil)
:use-module ((system vm core) :use-module (system vm objcode)
:select (the-vm vm-load objcode->u8vector load-objcode)) :use-module (system vm vm) ;; for compile-time evaluation
:use-module (system vm assemble) :use-module (system vm assemble)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:export (syntax-error compile-file load-source-file load-file :export (syntax-error compile-file load-source-file load-file

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

@ -24,7 +24,9 @@
:use-module (system base pmatch) :use-module (system base pmatch)
:use-module (system base compile) :use-module (system base compile)
:use-module (system repl common) :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 base language) (lookup-language)
:autoload (system il glil) (pprint-glil) :autoload (system il glil) (pprint-glil)
:autoload (system vm disasm) (disassemble-program disassemble-objcode) :autoload (system vm disasm) (disassemble-program disassemble-objcode)
@ -61,7 +63,7 @@
(lambda (p) (lambda (p)
(if (program? p) (if (program? p)
(program-documentation p) (program-documentation p)
(procedure-documentation p))))) (old-definition p)))))
(define *command-module* (current-module)) (define *command-module* (current-module))
(define (command-name c) (car c)) (define (command-name c) (car c))

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

@ -23,7 +23,7 @@
:use-syntax (system base syntax) :use-syntax (system base syntax)
:use-module (system base compile) :use-module (system base compile)
:use-module (system base language) :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 :export (<repl> make-repl repl-vm repl-language repl-options
repl-tm-stats repl-gc-stats repl-vm-stats repl-tm-stats repl-gc-stats repl-vm-stats
repl-welcome repl-prompt repl-read repl-compile repl-eval repl-welcome repl-prompt repl-read repl-compile repl-eval

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

@ -26,7 +26,7 @@
:use-module (system base language) :use-module (system base language)
:use-module (system repl common) :use-module (system repl common)
:use-module (system repl command) :use-module (system repl command)
:use-module (system vm core) :use-module (system vm vm)
:use-module (system vm debug) :use-module (system vm debug)
:use-module (ice-9 rdelim) :use-module (ice-9 rdelim)
:export (start-repl)) :export (start-repl))

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

@ -22,10 +22,9 @@
(define-module (system vm assemble) (define-module (system vm assemble)
:use-syntax (system base syntax) :use-syntax (system base syntax)
:use-module (system il glil) :use-module (system il glil)
:use-module ((system vm core) :use-module (system vm instruction)
:select (instruction? instruction-pops :use-module (system vm objcode)
make-binding :use-module ((system vm program) :select (make-binding))
bytecode->objcode))
:use-module (system vm conv) :use-module (system vm conv)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (ice-9 common-list) :use-module (ice-9 common-list)

16
module/system/vm/bootstrap.scm
View file

@ -25,15 +25,7 @@
;;; Core procedures ;;; Core procedures
;;; ;;;
(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm")) ;; 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
(module-export! (current-module) ;; if they are present.
(delq! '%module-public-interface (dynamic-call "scm_bootstrap_vm" (dynamic-link "libguile-vm"))
(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)))))

4
module/system/vm/conv.scm
View file

@ -20,9 +20,7 @@
;;; Code: ;;; Code:
(define-module (system vm conv) (define-module (system vm conv)
:use-module ((system vm core) :use-module (system vm instruction)
:select (instruction? instruction-length
instruction->opcode opcode->instruction))
:use-module (system base pmatch) :use-module (system base pmatch)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (srfi srfi-4) :use-module (srfi srfi-4)

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

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

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

@ -21,8 +21,7 @@
(define-module (system vm debug) (define-module (system vm debug)
:use-syntax (system base syntax) :use-syntax (system base syntax)
;; :use-module ((system vm core) :use-module (system vm vm)
;; :select (vm-last-frame-chain vm-backtrace))
:use-module (system vm frame) :use-module (system vm frame)
:use-module (ice-9 format) :use-module (ice-9 format)
:export (vm-debugger vm-backtrace)) :export (vm-debugger vm-backtrace))

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

@ -21,7 +21,8 @@
(define-module (system vm disasm) (define-module (system vm disasm)
:use-module (system base pmatch) :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 (system vm conv)
:use-module (ice-9 regex) :use-module (ice-9 regex)
:use-module (ice-9 format) :use-module (ice-9 format)
@ -102,6 +103,7 @@
(let ((info (object->string (car l)))) (let ((info (object->string (car l))))
(print-info n info #f))))) (print-info n info #f)))))
;; FIXME: update for recent meta changes
(define (disassemble-meta meta) (define (disassemble-meta meta)
(display "Meta info:\n\n") (display "Meta info:\n\n")
(for-each (lambda (data) (for-each (lambda (data)

113
module/system/vm/frame.scm
View file

@ -20,12 +20,19 @@
;;; Code: ;;; Code:
(define-module (system vm frame) (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 :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 ;;; Frame chain
;;; ;;;
@ -33,21 +40,15 @@
(define frame-number (make-object-property)) (define frame-number (make-object-property))
(define frame-address (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) (define (make-frame-chain frame addr)
(let* ((link (vm:frame-dynamic-link frame)) (let* ((link (frame-dynamic-link frame))
(chain (if (eq? link #t) (chain (if (eq? link #t)
'() '()
(cons frame (make-frame-chain (cons frame (make-frame-chain
link (vm:frame-return-address frame)))))) link (frame-return-address frame))))))
(set! (frame-number frame) (length chain)) (set! (frame-number frame) (length chain))
(set! (frame-address frame) (set! (frame-address frame)
(- addr (program-base (vm:frame-program frame)))) (- addr (program-base (frame-program frame))))
chain)) chain))
@ -56,7 +57,7 @@
;;; ;;;
(define (print-frame frame) (define (print-frame frame)
(format #t "#~A " (vm:frame-number frame)) (format #t "#~A " (frame-number frame))
(print-frame-call frame) (print-frame-call frame)
(newline)) (newline))
@ -72,12 +73,88 @@
(else (vector (abbrev (vector-ref x 0)) '...)))) (else (vector (abbrev (vector-ref x 0)) '...))))
(else x))) (else x)))
(write (abbrev (cons (program-name frame) (write (abbrev (cons (program-name frame)
(vm:frame-arguments frame))))) (frame-arguments frame)))))
(define (program-name frame) (define (program-name frame)
(let ((prog (vm:frame-program frame)) (let ((prog (frame-program frame))
(link (vm:frame-dynamic-link frame))) (link (frame-dynamic-link frame)))
(or (object-property prog 'name) (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)) (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
prog (module-obarray (current-module)))))) 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)))

28
module/system/vm/instruction.scm Normal file
View file

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

26
module/system/vm/objcode.scm Normal file
View file

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

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

@ -20,7 +20,7 @@
;;; Code: ;;; Code:
(define-module (system vm profile) (define-module (system vm profile)
:use-module (system vm core) :use-module (system vm vm)
:use-module (ice-9 format) :use-module (ice-9 format)
:export (vm-profile)) :export (vm-profile))

63
module/system/vm/program.scm Normal file
View file

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

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

@ -21,7 +21,7 @@
(define-module (system vm trace) (define-module (system vm trace)
:use-syntax (system base syntax) :use-syntax (system base syntax)
:use-module (system vm core) :use-module (system vm vm)
:use-module (system vm frame) :use-module (system vm frame)
:use-module (ice-9 format) :use-module (ice-9 format)
:export (vm-trace vm-trace-on vm-trace-off)) :export (vm-trace vm-trace-on vm-trace-off))

62
module/system/vm/vm.scm Normal file
View file

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

1
src/Makefile.am
View file

@ -9,6 +9,7 @@ CFLAGS:=$(filter-out -Wmissing-prototypes,$(CFLAGS))
lib_LTLIBRARIES = libguile-vm.la lib_LTLIBRARIES = libguile-vm.la
libguile_vm_la_SOURCES = \ libguile_vm_la_SOURCES = \
bootstrap.h \
envs.c frames.c instructions.c objcodes.c programs.c vm.c \ envs.c frames.c instructions.c objcodes.c programs.c vm.c \
envs.h frames.h instructions.h objcodes.h programs.h vm.h \ envs.h frames.h instructions.h objcodes.h programs.h vm.h \
vm_engine.h vm_expand.h vm_engine.h vm_expand.h

53
src/bootstrap.h Normal file
View file

@ -0,0 +1,53 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* The exception is that, if you link the GUILE library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
* linking the GUILE library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
* Free Software Foundation under the name GUILE. If you copy
* code from other Free Software Foundation releases into a copy of
* GUILE, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice. */
#ifndef _SCM_VM_BOOTSTRAP_H_
#define _SCM_VM_BOOTSTRAP_H_
extern void scm_bootstrap_vm (void);
#endif /* _SCM_VM_BOOTSTRAP_H_ */
/*
Local Variables:
c-file-style: "gnu"
End:
*/

9
src/frames.c
View file

@ -44,6 +44,7 @@
#endif #endif
#include <string.h> #include <string.h>
#include "bootstrap.h"
#include "frames.h" #include "frames.h"
@ -172,11 +173,17 @@ SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
void void
scm_init_frames (void) scm_bootstrap_frames (void)
{ {
scm_tc16_heap_frame = scm_make_smob_type ("frame", 0); scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark); scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free); scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
}
void
scm_init_frames (void)
{
scm_bootstrap_vm ();
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER
#include "frames.x" #include "frames.x"

1
src/frames.h
View file

@ -105,6 +105,7 @@ extern scm_t_bits scm_tc16_heap_frame;
#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P) #define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
extern SCM scm_c_make_heap_frame (SCM *fp); extern SCM scm_c_make_heap_frame (SCM *fp);
extern void scm_bootstrap_frames (void);
extern void scm_init_frames (void); extern void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */ #endif /* _SCM_FRAMES_H_ */

8
src/instructions.c
View file

@ -44,6 +44,7 @@
#endif #endif
#include <string.h> #include <string.h>
#include "bootstrap.h"
#include "instructions.h" #include "instructions.h"
struct scm_instruction scm_instruction_table[] = { struct scm_instruction scm_instruction_table[] = {
@ -158,9 +159,16 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
void
scm_bootstrap_instructions (void)
{
}
void void
scm_init_instructions (void) scm_init_instructions (void)
{ {
scm_bootstrap_vm ();
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER
#include "instructions.x" #include "instructions.x"
#endif #endif

1
src/instructions.h
View file

@ -79,6 +79,7 @@ struct scm_instruction {
extern struct scm_instruction scm_instruction_table[]; extern struct scm_instruction scm_instruction_table[];
extern struct scm_instruction *scm_lookup_instruction (SCM name); extern struct scm_instruction *scm_lookup_instruction (SCM name);
extern void scm_bootstrap_instructions (void);
extern void scm_init_instructions (void); extern void scm_init_instructions (void);
#endif /* _SCM_INSTRUCTIONS_H_ */ #endif /* _SCM_INSTRUCTIONS_H_ */

9
src/objcodes.c
View file

@ -51,6 +51,7 @@
#include <sys/types.h> #include <sys/types.h>
#include <assert.h> #include <assert.h>
#include "bootstrap.h"
#include "programs.h" #include "programs.h"
#include "objcodes.h" #include "objcodes.h"
@ -277,10 +278,16 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
void void
scm_init_objcodes (void) scm_bootstrap_objcodes (void)
{ {
scm_tc16_objcode = scm_make_smob_type ("objcode", 0); scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
scm_set_smob_free (scm_tc16_objcode, objcode_free); scm_set_smob_free (scm_tc16_objcode, objcode_free);
}
void
scm_init_objcodes (void)
{
scm_bootstrap_vm ();
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER
#include "objcodes.x" #include "objcodes.x"

4
src/objcodes.h
View file

@ -60,6 +60,10 @@ extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base) #define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd) #define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd)
extern SCM scm_load_objcode (SCM file);
extern SCM scm_objcode_to_program (SCM objcode);
extern void scm_bootstrap_objcodes (void);
extern void scm_init_objcodes (void); extern void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */ #endif /* _SCM_OBJCODES_H_ */

9
src/programs.c
View file

@ -44,6 +44,7 @@
#endif #endif
#include <string.h> #include <string.h>
#include "bootstrap.h"
#include "instructions.h" #include "instructions.h"
#include "programs.h" #include "programs.h"
#include "vm.h" #include "vm.h"
@ -227,7 +228,7 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
void void
scm_init_programs (void) scm_bootstrap_programs (void)
{ {
zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F)); zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
@ -235,7 +236,13 @@ scm_init_programs (void)
scm_set_smob_mark (scm_tc16_program, program_mark); scm_set_smob_mark (scm_tc16_program, program_mark);
scm_set_smob_free (scm_tc16_program, program_free); scm_set_smob_free (scm_tc16_program, program_free);
scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1); scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
}
void
scm_init_programs (void)
{
scm_bootstrap_vm ();
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER
#include "programs.x" #include "programs.x"
#endif #endif

1
src/programs.h
View file

@ -72,6 +72,7 @@ extern scm_t_bits scm_tc16_program;
extern SCM scm_c_make_program (void *addr, size_t size, SCM holder); extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
extern SCM scm_c_make_closure (SCM program, SCM external); extern SCM scm_c_make_closure (SCM program, SCM external);
extern void scm_bootstrap_programs (void);
extern void scm_init_programs (void); extern void scm_init_programs (void);
#endif /* _SCM_PROGRAMS_H_ */ #endif /* _SCM_PROGRAMS_H_ */

37
src/vm.c
View file

@ -561,13 +561,25 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
* Initialize * Initialize
*/ */
void SCM scm_load_compiled_with_vm (SCM file)
scm_init_vm (void)
{ {
scm_init_frames (); SCM program = scm_objcode_to_program (scm_load_objcode (file));
scm_init_instructions ();
scm_init_objcodes (); return vm_run (the_vm, program, SCM_EOL);
scm_init_programs (); }
void
scm_bootstrap_vm (void)
{
static int strappage = 0;
if (strappage)
return;
scm_bootstrap_frames ();
scm_bootstrap_instructions ();
scm_bootstrap_objcodes ();
scm_bootstrap_programs ();
scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark); scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
@ -580,6 +592,19 @@ scm_init_vm (void)
the_vm = scm_permanent_object (make_vm ()); the_vm = scm_permanent_object (make_vm ());
/* a bit heavy-handed, this */
scm_variable_set_x (scm_c_lookup ("load-compiled"),
scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
scm_load_compiled_with_vm));
strappage = 1;
}
void
scm_init_vm (void)
{
scm_bootstrap_vm ();
#ifndef SCM_MAGIC_SNARFER #ifndef SCM_MAGIC_SNARFER
#include "vm.x" #include "vm.x"
#endif #endif

2
src/vm.h
View file

@ -79,6 +79,8 @@ extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
extern SCM scm_vm_option_ref (SCM vm, SCM key); extern SCM scm_vm_option_ref (SCM vm, SCM key);
extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
extern SCM scm_load_compiled_with_vm (SCM file);
extern void scm_init_vm (void); extern void scm_init_vm (void);
#endif /* _SCM_VM_H_ */ #endif /* _SCM_VM_H_ */