object file is too small.
* doc/guile-vm.texi: Documented `make-closure'. Improved the documentation
of `load-program'.
* testsuite: New directory.
* configure.in: Added `testsuite/Makefile' to `AC_OUTPUT'.
* Makefile.am (SUBDIRS): Added `testsuite'.
* src/vm_engine.h (VM_CHECK_OBJECT): New option.
(CHECK_OBJECT): New macro.
* src/vm_system.c (object-ref): Use VM_CHECK_OBJECT.
* module/system/vm/assemble.scm (preprocess): Commented out the debugging
code.
* benchmark/lib.scm (do-loop): New procedure.
git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-2
-SUBDIRS = src doc module
+SUBDIRS = src doc module testsuite
EXTRA_DIST = acconfig.h
0
(loopi (1- n)))))
+(define (do-loop n)
+ ;; Same as `loop' using `do'.
+ (do ((i n (1- i)))
+ ((= 0 i))
+ ;; do nothing
+ ))
+
(define (do-cons x)
;; This one shows that the built-in `cons' instruction yields a significant
AC_OUTPUT(Makefile src/Makefile doc/Makefile module/Makefile
module/system/Makefile module/system/base/Makefile
module/system/vm/Makefile module/system/il/Makefile
- module/system/repl/Makefile)
+ module/system/repl/Makefile
+ testsuite/Makefile)
@section Subprogram call
-@example
- (define (plus a b) (+ a b))
- (plus 1 2) ->
-
- %pushi 1 ; argument 1
- %pushi 2 ; argument 2
- %loadt (plus . #<program xxx>) ; load the program
- %call 2 ; call it with two arguments
- %pushl (0 . 0) ; argument 1
- %loadl (0 . 1) ; argument 2
- add2 ; ac = 1 + 2
- %return ; result is 3
-@end example
@node Instruction Set, , Program Execution, Top
@chapter Instruction Set
program's list of external variables.
@end deffn
-Let's look at a more complete example:
+@deffn @insn{} make-closure
+Pop the program object from the stack and assign it the current
+closure variable list as its closure. Push the result program
+object.
+@end deffn
+
+Let's illustrate this:
@example
(let ((x 2))
This yields the following code:
@example
- ;; the traditional program prologue
+ ;; the traditional program prologue with NLOCS = 0 and NEXTS = 1
+
0 (make-int8 2)
2 (external-set 0)
4 (make-int8 4)
- 6 (link "+") ;; lookup `+'
- 9 (vector 1) ;; create the external variable vector for
- ;; later use by `object-ref' and `object-set'
+ 6 (link "+") ;; lookup `+'
+ 9 (vector 1) ;; create the external variable vector for
+ ;; later use by `object-ref' and `object-set'
...
40 (load-program ##34#)
- 59 (return)
+ 59 (make-closure) ;; assign the current closure to the program
+ ;; just pushed by `load-program'
+ 60 (return)
@end example
The program loaded here by @var{load-program} contains the following
16 (return) ;; return it
@end example
-At this point, you know pretty much everything about the three types
-of variables a program may need to access.
+At this point, you should know pretty much everything about the three
+types of variables a program may need to access.
@node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set
@cindex Object table
In order to handle such bindings, each program has an @dfn{object
-table} associated to it. This table (actually a vector) contains all
-the variable objects corresponding to the external bindings referenced
-by the program. The object table of a program is initialized right
-before a program is loaded and run with @var{load-program}.
-
-Therefore, external bindings only need to be looked up once before the
-program is loaded. References to the corresponding external variables
-from within the program are then performed via the @var{object-ref}
-instruction and are almost as fast as local variable references.
+table} associated to it. This table (actually a Scheme vector)
+contains all constant objects referenced by the program. The object
+table of a program is initialized right before a program is loaded
+with @var{load-program}.
+
+Variable objects are one such type of constant object: when a global
+binding is defined, a variable object is associated to it and that
+object will remain constant over time, even if the value bound to it
+changes. Therefore, external bindings only need to be looked up once
+when the program is loaded. References to the corresponding external
+variables from within the program are then performed via the
+@var{object-ref} instruction and are almost as fast as local variable
+references.
Let us consider the following program (procedure) which references
external bindings @code{frob} and @var{%magic}:
this bytecode looks like:
@example
-z(object-ref 0) ;; push the variable object of `frob'
+(object-ref 0) ;; push the variable object of `frob'
(variable-ref) ;; dereference it
(local-ref 0) ;; push the value of `x'
(object-ref 1) ;; push the variable object of `%magic'
:use-module (ice-9 regex)
:use-module (ice-9 common-list)
:use-module (srfi srfi-4)
- :export (preprocess assemble))
+ :export (preprocess codegen assemble))
(define (assemble glil env . opts)
(codegen (preprocess glil #f) #t))
;;;
(define (preprocess x e)
+; (format #t "entering~%")
(match x
(($ <glil-asm> vars body)
- (let* ((venv (<venv> :parent e :nexts vars.nexts :closure? #f))
+; (format #t "preparing to recurse~%")
+ (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
(body (map (lambda (x) (preprocess x venv)) body)))
(<vm-asm> :venv venv :glil x :body body)))
(($ <glil-external> op depth index)
- (do ((d depth (1- d))
- (e e e.parent))
+; (format #t "preparing to return due to external: ~a ~a ~a [e=~a]~%"
+; op depth index e)
+ (do ((d depth (- d 1))
+ (e e (slot e 'parent)))
((= d 0))
- (set! e.closure? #t))
+ (set! (slot e 'closure?) #t))
+; (format #t "returning due to external~%")
x)
- (else x)))
+ (else
+ (begin
+; (format #t "returning~%")
+ x))))
\f
;;;
(match x
(($ <vm-asm> venv)
(push-object! (codegen x #f))
- (if venv.closure? (push-code! `(make-closure))))
+ (if (slot venv 'closure?) (push-code! `(make-closure))))
(($ <glil-bind> binds)
(let ((bindings
struct scm_objcode *p;
ret = fstat (fd, &st);
- if ((ret < 0) || (st.st_size <= strlen (OBJCODE_COOKIE)))
+ if (ret < 0)
SCM_SYSERROR;
+ if (st.st_size <= strlen (OBJCODE_COOKIE))
+ scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+ SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
+
addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
if (addr == MAP_FAILED)
SCM_SYSERROR;
struct scm_program *bp = NULL; /* program base pointer */
SCM external = SCM_EOL; /* external environment */
SCM *objects = NULL; /* constant objects */
+ size_t object_count; /* length of OBJECTS */
SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
goto vm_error;
vm_error_wrong_type_apply:
- err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S");
- err_args = SCM_LIST1 (program);
+ err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+ "[IP offset: ~a]");
+ err_args = SCM_LIST2 (program,
+ SCM_I_MAKINUM (ip - bp->base));
goto vm_error;
vm_error_stack_overflow:
goto vm_error;
#endif
+#if VM_CHECK_OBJECT
+ vm_error_object:
+ err_msg = scm_from_locale_string ("VM: Invalid object table access");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
vm_error:
SYNC_ALL ();
vp->last_frame = vm_heapify_frames (vm);
#define VM_USE_HOOKS 1 /* Various hooks */
#define VM_USE_CLOCK 1 /* Bogoclock */
#define VM_CHECK_EXTERNAL 1 /* Check external link */
+#define VM_CHECK_OBJECT 1 /* Check object table */
\f
/*
/* Get a local copy of the program's "object table" (i.e. the vector of
external bindings that are referenced by the program), initialized by
`load-program'. */
-#define CACHE_PROGRAM() \
-{ \
- size_t _vsize; \
- ssize_t _vincr; \
- scm_t_array_handle _vhandle; \
- \
- bp = SCM_PROGRAM_DATA (program); \
- /* Was: objects = SCM_VELTS (bp->objs); */ \
- objects = scm_vector_elements (bp->objs, &_vhandle, \
- &_vsize, &_vincr); \
- scm_array_handle_release (&_vhandle); \
+#define CACHE_PROGRAM() \
+{ \
+ ssize_t _vincr; \
+ scm_t_array_handle _vhandle; \
+ \
+ bp = SCM_PROGRAM_DATA (program); \
+ /* Was: objects = SCM_VELTS (bp->objs); */ \
+ objects = scm_vector_elements (bp->objs, &_vhandle, \
+ &object_count, &_vincr); \
+ scm_array_handle_release (&_vhandle); \
}
#define SYNC_BEFORE_GC() \
#define CHECK_EXTERNAL(e)
#endif
+/* Accesses to a program's object table. */
+#if VM_CHECK_OBJECT
+#define CHECK_OBJECT(_num) \
+ do { if ((_num) >= object_count) goto vm_error_object; } while (0)
+#else
+#define CHECK_OBJECT(_num)
+#endif
+
\f
/*
* Hooks
VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
{
- PUSH (OBJECT_REF (FETCH ()));
+ register objnum = FETCH ();
+ CHECK_OBJECT (objnum);
+ PUSH (OBJECT_REF (objnum));
NEXT;
}
--- /dev/null
+# The test programs.
+
+# The Libtool executable.
+GUILE_VM = $(top_srcdir)/src/guile-vm
+
+vm_test_files = \
+ t-global-bindings.scm \
+ t-closure.scm \
+ t-closure2.scm \
+ t-closure3.scm \
+ t-do-loop.scm \
+ t-macros.scm \
+ t-proc-with-setter.scm \
+ t-values.scm \
+ t-records.scm \
+ t-match.scm
+
+EXTRA_DIST = run-vm-tests.scm $(vm_test_files)
+
+
+check:
+ $(GUILE_VM) -L $(top_srcdir)/module \
+ -l run-vm-tests.scm -e run-vm-tests \
+ $(vm_test_files)
--- /dev/null
+;;; A simple test-running script.
+
+(use-modules (system vm core)
+ (system vm disasm)
+ (system base compile)
+ (system base language)
+
+ (srfi srfi-1))
+
+\f
+(define *scheme* (lookup-language 'scheme))
+
+(define (fetch-sexp-from-file file)
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((sexp (read))
+ (result '()))
+ (if (eof-object? sexp)
+ (cons 'begin (reverse result))
+ (loop (read) (cons sexp result)))))))
+
+(define (compile-to-objcode sexp)
+ "Compile the expression @var{sexp} into a VM program and return it."
+ (compile-in sexp (current-module) *scheme*))
+
+(define (run-vm-program objcode)
+ "Run VM program contained into @var{objcode}."
+ (vm-load (the-vm) objcode))
+
+(define (run-test-from-file file)
+ "Run test from source file @var{file} and return a value indicating whether
+it succeeded."
+ (run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
+
+\f
+(define-macro (watch-proc proc-name str)
+ `(let ((orig-proc ,proc-name))
+ (set! ,proc-name
+ (lambda args
+ (format #t (string-append ,str "... "))
+ (apply orig-proc args)))))
+
+(watch-proc fetch-sexp-from-file "reading")
+(watch-proc compile-to-objcode "compiling")
+(watch-proc run-vm-program "running")
+
+\f
+;; The program.
+
+(define (run-vm-tests files)
+ (let* ((res (map (lambda (file)
+ (format #t "running `~a'... " file)
+ (if (catch #t
+ (lambda ()
+ (run-test-from-file file))
+ (lambda (key . args)
+ (format #t "[~a/~a] " key args)
+ #f))
+ (format #t "ok~%")
+ (begin (format #t "FAILED~%") #f)))
+ files))
+ (total (length files))
+ (failed (length (filter not res))))
+
+ (if (= 0 failed)
+ (begin
+ (format #t "~%All ~a tests passed~%" total)
+ (exit 0))
+ (begin
+ (format #t "~%~a tests failed out of ~a~%"
+ failed total)
+ (exit failed)))))
+
--- /dev/null
+(let ((x 2))
+ (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++)))
--- /dev/null
+
+(define (uid)
+ (let* ((x 2)
+ (do-uid (lambda ()
+ (let ((x++ (+ 1 x)))
+ (set! x x++)
+ x++))))
+ (do-uid)))
--- /dev/null
+(define (stuff)
+ (let* ((x 2)
+ (chbouib (lambda (z)
+ (+ 7 z x))))
+ (chbouib 77)))
--- /dev/null
+(let ((n+ 0))
+ (do ((n- 5 (1- n-))
+ (n+ n+ (1+ n+)))
+ ((= n- 0))
+ (format #t "n- = ~a~%" n-)))
--- /dev/null
+;; Are global bindings reachable at run-time? This relies on the
+;; `object-ref' and `object-set' instructions.
+
+(begin
+
+ (define the-binding "hello")
+
+ ((lambda () the-binding))
+
+ ((lambda () (set! the-binding "world")))
+
+ ((lambda () the-binding)))
+
--- /dev/null
+;; Are macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
--- /dev/null
+(use-modules (ice-9 match)
+ (srfi srfi-9)) ;; record type
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+(define (matches? obj)
+; (format #t "matches? ~a~%" obj)
+ (match obj
+ (($ stuff) => #t)
+; (blurps #t)
+ ("hello" #t)
+ (else #f)))
+
+\f
+;(format #t "go!~%")
+(and (matches? (%make-stuff 12))
+ (matches? (%make-stuff 7))
+ (matches? "hello")
+; (matches? 'blurps)
+ (not (matches? 66)))
--- /dev/null
+(define the-struct (vector 1 2))
+
+(define get/set
+ (make-procedure-with-setter
+ (lambda (struct name)
+ (case name
+ ((first) (vector-ref struct 0))
+ ((second) (vector-ref struct 1))
+ (else #f)))
+ (lambda (struct name val)
+ (case name
+ ((first) (vector-set! struct 0 val))
+ ((second) (vector-set! struct 1 val))
+ (else #f)))))
--- /dev/null
+(use-modules (srfi srfi-9))
+
+(define-record-type <stuff>
+ (%make-stuff chbouib)
+ stuff?
+ (chbouib stuff:chbouib stuff:set-chbouib!))
+
+\f
+(and (stuff? (%make-stuff 12))
+ (= 7 (stuff:chbouib (%make-stuff 7)))
+ (not (stuff? 12))
+ (not (false-if-exception (%make-stuff))))
--- /dev/null
+(use-modules (ice-9 receive))
+
+(define (do-stuff x y)
+ (values x y))
+
+(call-with-values (lambda () (values 1 2))
+ (lambda (x y) (cons x y)))
+
--- /dev/null
+-*- Outline -*-
+
+Once (system vm assemble) is compiled, things start to fail in
+unpredictable ways.
+
+* `compile-file' of non-closure-using programs works
+
+$ guile-disasm t-records.go > t-records.ref.asm
+...
+$ diff -uBb t-macros.*.asm
+$ diff -uBb t-records.*.asm
+$ diff -uBb t-global-bindings.*.asm
+
+* `compile-file' of closure-using programs fails
+
+ERROR: During compiling t-closure.scm:
+ERROR: VM: Wrong type to apply: #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) [IP offset: 28]
+
+guile> (vm-debugger (the-vm))
+debug> bt
+#1 #<variable 30b12468 value: (#(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 0) (nexts . 1))) (#(<glil-const> 2) #(<glil-bind> ((x external 0))) #(<glil-external> set 0 0) #(<glil-asm> #(<glil-vars> ((nargs . 0) (nrest . 0) (nlocs . 1) (nexts . 0))) (#(<glil-module> ref #f +) #(<glil-const> 1) #(<glil-external> ref 1 0) #(<glil-call> call 2) #(<glil-source> (2 . 15)) #(<glil-bind> ((x++ local 0))) #(<glil-local> set 0) #(<glil-local> ref 0) #(<glil-external> set 1 0) #(<glil-local> ref 0) #(<glil-call> return 0) #(<glil-unbind>))) #(<glil-call> return 0) #(<glil-unbind>))) #<directory (guile-user) 100742d0> ())>
+#2 (#<program 30ae74b8> #(<glil-vars> ...) (#(<glil-const> ...) #(<glil-bind> ...) ...))
+#3 (#<program 30af7090>)
+#4 (#<program 30af94c0> #(<glil-vars> ...) (#(<glil-module> ...) #(<glil-const> ...) ...))
+#5 (#<program 30b00108>)
+#6 (#<program 30b02590> ref ...)
+#7 (_l 1 #(<venv> ...))
+guile> (vm-debugger (the-vm))
+debug> stack
+(#t closure? #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) #<procedure #f (struct name val)> #<primitive-generic map> #<primitive-generic map> #<program 30998470>)
+
+* Compiling anything "by hand" fails
+
+** Example 1: the read/compile/run loop
+
+guile> (set! %load-path (cons "/home/ludo/src/guile-vm/module" %load-path))
+guile> (use-modules (system vm assemble)(system vm core)(system repl repl))
+guile> (start-repl 'scheme)
+Guile Scheme interpreter 0.5 on Guile 1.7.2
+Copyright (C) 2001 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@guile-user> (use-modules (ice-9 match)
+ (system base syntax)
+ (system vm assemble))
+
+(define (%preprocess x e)
+ (match x
+ (($ <glil-asm> vars body)
+ (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+ (body (map (lambda (x) (preprocess x venv)) body)))
+ (<vm-asm> :venv venv :glil x :body body)))
+ (($ <glil-external> op depth index)
+ (do ((d depth (1- d))
+ (e e (slot e 'parent)))
+ ((= d 0))
+ (set! (slot e 'closure?) #t))
+ x)
+ (else x)))
+
+scheme@guile-user> preprocess
+#<procedure preprocess (x e)>
+scheme@guile-user> (getpid)
+470
+scheme@guile-user> (set! preprocess %preprocess)
+scheme@guile-user> preprocess
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user> getpid
+ERROR: VM: Unbound variable: #<variable 30a0d5e0 value: #<undefined>>
+scheme@guile-user>
+
+
+** Example 2: the test suite (which also reads/compiles/runs)
+
+All the closure-using tests fail.
+
+ludo@lully:~/src/guile-vm/testsuite $ make check
+../src/guile-vm -L ../module \
+ -l run-vm-tests.scm -e run-vm-tests \
+ t-global-bindings.scm t-closure.scm t-closure2.scm t-closure3.scm t-do-loop.scm t-macros.scm t-proc-with-setter.scm t-values.scm t-records.scm t-match.scm
+
+running `t-global-bindings.scm'... reading... compiling... running... ok
+running `t-closure.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure2.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-closure3.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong ype to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 0) (closure? . #f)))) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-do-loop.scm'... reading... compiling... [vm-error/(vm-run VM: Wrong type to apply: ~S [IP offset: ~a] (#(<venv> ((parent . #(<venv> ((parent . #f) (nexts . 1) (closure? . #f)))) (nexts . 0) (closure? . #f))) 28))] FAILED
+running `t-macros.scm'... reading... compiling... running... ok
+running `t-proc-with-setter.scm'... reading... compiling... running... ok
+running `t-values.scm'... reading... compiling... running... ok
+running `t-records.scm'... reading... compiling... running... ok
+running `t-match.scm'... reading... compiling... running... ok
+
+4 tests failed out of 10
+make: *** [check] Error 4
+
HCoop / bpt / guile.git / commitdiff