mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +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 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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:
(define-module (system vm profile)
:use-module (system vm core)
:use-module (system vm vm)
:use-module (ice-9 format)
: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)
: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))

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