mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fixed a Scheme translation bug; cleaned compilation with GCC 4.

Browse source 
* module/language/scheme/translate.scm (trans-pair): In the `set!' case,
  when a procedure-with-setter is passed, call `trans:pair' with an
  actual pair.  This fixes a long-lasting bug which prevented compilation
  of `set!' statements with procedures-with-setter (this showed up when
  compiling `(system vm assemble)').

* module/system/base/compile.scm: Added `objcode->u8vector' to the
  `#:select' clause.

* module/system/base/syntax.scm: Cosmetic changes.

* module/system/vm/assemble.scm (preprocess): Removed debugging
  statements.

* src/frames.c: Cosmetic changes.

* src/frames.h (SCM_FRAME_SET_DYNAMIC_LINK): New.

* src/objcodes.c: Use `scm_t_uint8' instead of `char' when relevant.

* src/vm.c (vm_heapify_frames_1): Use `SCM_FRAME_SET_DYNAMIC_LINK ()'.

* src/vm_loader.c: Added casts to mute GCC 4 warnings.

* testsuite/run-vm-tests.scm (*scheme*): Renamed to `%scheme'.
  (run-test-from-file): Renamed to `compile/run-test-from-file'.
  (run-vm-tests): Run each test using both the VM and the interpreter;
  compare the results.

* testsuite/t-proc-with-setter.scm: Try out `get/set'.

* doc/Makefile.am (info_TEXINFOS): New.

* doc/guile-vm.texi: Added index entries and indices.

* doc/texinfo.tex: New file.

git-archimport-id: lcourtes@laas.fr--2005-mobile/guile-vm--mobile--0.6--patch-5
This commit is contained in:
Ludovic Courtes 2005-11-01 21:29:04 +00:00 • committed by Ludovic Courtès
parent 49edef60dc
commit b6368dbbb9
19 changed files with 7212 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

3
doc/Makefile.am
View file

@ -1,2 +1 @@
texi_TEXINFOS = guile-vm.texi
MAINTAINERCLEANFILES = Makefile.in
info_TEXINFOS = guile-vm.texi

47
doc/guile-vm.texi
View file

@ -102,6 +102,9 @@ However, be warned that important parts still correspond to version
* Variable Management::
* Instruction Set::
* The Compiler::
* Concept Index::
* Function and Instruction Index::
* Command and Variable Index::
@detailmenu
--- The Detailed Node Listing ---
@ -528,7 +531,7 @@ itself, in the environment in which it will evaluate at run-time. In
a sense, a program's environment and its bindings are an implicit
parameter of every program.
@cindex Object table
@cindex object table
In order to handle such bindings, each program has an @dfn{object
table} associated to it. This table (actually a Scheme vector)
contains all constant objects referenced by the program. The object
@ -723,7 +726,7 @@ Push @code{#t} onto the stack.
@node The Compiler, , Instruction Set, Top
@node The Compiler, Concept Index, Instruction Set, Top
@chapter The Compiler
This section describes Guile-VM's compiler and the compilation process
@ -743,6 +746,13 @@ Set}).
Compilation in Guile-VM is a three-stage process:
@cindex intermediate language
@cindex assembler
@cindex compiler
@cindex GHIL
@cindex GLIL
@cindex bytecode
@enumerate
@item the source programming language (e.g. R5RS Scheme) is read and
translated into GHIL, @dfn{Guile's High-Level Intermediate Language};
@ -756,6 +766,8 @@ The use of two separate intermediate languages eases the
implementation of front-ends since the gap between high-level
languages like Scheme and GHIL is relatively small.
@findex compile-file
@vindex guilec
From an end-user viewpoint, compiling a Guile program into bytecode
can be done either by using the @command{guilec} command-line tool, or
by using the @code{compile-file} procedure exported by the
@ -804,9 +816,9 @@ represents a particular language feature. These records are all
defined in the @code{(system il ghil)} module and are named
@code{<ghil-*>}.
Each GHIL record has at least two fields: one containing the
Each GHIL record has at least two fields: one containing the
environment (Guile module) in which it is considered, and one
containing its location [FIXME: currently seems to be unused]. Below
containing its location [FIXME: currently seems to be unused]. Below
is a list of the main GHIL object types and their fields:
@example
@ -899,6 +911,8 @@ This is not unlike the VM's assembly language described in
@node The Assembler, , GLIL, The Compiler
@section The Assembler
@findex code->bytes
The final compilation step consists in converting the GLIL instruction
sequence into VM bytecode. This is what the @code{assemble} procedure
defined in the @code{(system vm assemble)} module is for. It relies
@ -917,25 +931,24 @@ form of an SRFI-4 @code{u8vector} or a @code{<bytespec>} object.
@end deffn
@c *********************************************************************
@c @node Concept Index, Command Index, Related Information, Top
@c @unnumbered Concept Index
@c @printindex cp
@node Concept Index, Function and Instruction Index, The Compiler, Top
@unnumbered Concept Index
@printindex cp
@c @node Command Index, Variable Index, Concept Index, Top
@c @unnumbered Command Index
@c @printindex fn
@node Function and Instruction Index, Command and Variable Index, Concept Index, Top
@unnumbered Function and Instruction Index
@printindex fn
@c @node Variable Index, , Command Index, Top
@c @unnumbered Variable Index
@c @printindex vr
@node Command and Variable Index, , Function and Instruction Index, Top
@unnumbered Command and Variable Index
@printindex vr
@bye
@c Local Variables:
@c mode:outline-minor
@c outline-regexp:"@\\(ch\\|sec\\|subs\\)"
@c ispell-local-dictionary: "american";
@c End:
@c LocalWords: bytecode

7086
doc/texinfo.tex Normal file
View file

File diff suppressed because it is too large Load diff

10
module/language/scheme/translate.scm
View file

@ -43,13 +43,13 @@
(cond ((pair? x)
(let ((y (macroexpand x)))
(if (eq? x y)
(trans-pair e (or (location x) l) (car x) (cdr x))
(trans e l y))))
(trans-pair e (or (location x) l) (car x) (cdr x))
(trans e l y))))
((symbol? x)
(let ((y (symbol-expand x)))
(if (symbol? y)
(<ghil-ref> e l (ghil-lookup e y))
(trans e l y))))
(<ghil-ref> e l (ghil-lookup e y))
(trans e l y))))
(else (<ghil-quote> e l x))))
(define (symbol-expand x)
@ -109,7 +109,7 @@
;; (set! (NAME ARGS...) VAL)
((((? symbol? name) . args) val)
;; -> ((setter NAME) ARGS... VAL)
(trans:pair `((setter ,name) (,@args ,val))))
(trans:pair `((setter ,name) . (,@args ,val))))
(else (bad-syntax))))

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

@ -25,7 +25,7 @@
:use-module (system il compile)
:use-module (system il glil)
:use-module ((system vm core)
#:select (the-vm vm-load))
#:select (the-vm vm-load objcode->u8vector))
:use-module (system vm assemble)
:use-module (ice-9 regex))
@ -68,9 +68,9 @@
(if (memq :c opts)
(pprint-glil objcode port)
(uniform-vector-write (objcode->u8vector objcode) port)))))
(format #t "Wrote ~A\n" comp))
(format #t "wrote ~A\n" comp))
(lambda (key . args)
(format #t "ERROR: During compiling ~A:\n" file)
(format #t "ERROR: during compilation of ~A:\n" file)
(display "ERROR: ")
(apply format #t (cadr args) (caddr args))
(newline)

7
module/system/base/syntax.scm
View file

@ -102,7 +102,7 @@
(def (if (pair? slot) (cdr slot) *unbound*))
(val (get-key args (symbol->keyword key) def)))
(if (eq? val *unbound*)
(error "Slot unbound:" key)
(error "slot unbound" key)
(cons key val))))
slots))
@ -116,14 +116,15 @@
(lambda (struct name)
(let ((data (assq name (vector-ref struct 1))))
(cond ((not data)
(error "Unknown slot:" name))
(error "unknown slot" name))
(else (cdr data)))))
(lambda (struct name val)
(let ((data (assq name (vector-ref struct 1))))
(cond ((not data)
(error "Unknown slot:" name))
(error "unknown slot" name))
(else (set-cdr! data val)))))))
;;;
;;; Variants
;;;

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

@ -50,26 +50,18 @@
;;;
(define (preprocess x e)
; (format #t "entering~%")
(match x
(($ <glil-asm> vars body)
; (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)
; (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))
(e e (slot e 'parent)))
((= d 0))
(set! (slot e 'closure?) #t))
; (format #t "returning due to external~%")
x)
(else
(begin
; (format #t "returning~%")
x))))
(else x)))
;;;

5
src/frames.c
View file

@ -140,8 +140,9 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_HEAP_FRAME (1, frame);
return scm_from_ulong ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_POINTER (frame))));
return scm_from_ulong ((unsigned long)
(SCM_FRAME_RETURN_ADDRESS
(SCM_HEAP_FRAME_POINTER (frame))));
}
#undef FUNC_NAME

25
src/frames.h
View file

@ -51,21 +51,26 @@
* VM frames
*/
/*
/* VM Frame Layout
---------------
| | <- fp + bp->nargs + bp->nlocs + 4
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| Dynamic link |
| Heap link |
| External link | <- fp + bp->nargs + bp->nlocs
| Local varialbe 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
+------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
| |
*/
As can be inferred from this drawing, it is assumed that
`sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
@ -76,10 +81,14 @@
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3])
#define SCM_FRAME_DYNAMIC_LINK(fp) SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2])
#define SCM_FRAME_HEAP_LINK(fp) SCM_FRAME_DATA_ADDRESS (fp)[1]
#define SCM_FRAME_EXTERNAL_LINK(fp) SCM_FRAME_DATA_ADDRESS (fp)[0]
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1])
#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
@ -92,7 +101,7 @@ extern scm_t_bits scm_tc16_heap_frame;
#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f))
#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f)[0])
#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0)
#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2)
#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)

4
src/objcodes.c
View file

@ -183,7 +183,7 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
ssize_t increment;
scm_t_array_handle handle;
char *base;
const char *c_bytecode;
const scm_t_uint8 *c_bytecode;
SCM objcode;
if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
@ -235,7 +235,7 @@ SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
"")
#define FUNC_NAME s_scm_objcode_to_u8vector
{
char *u8vector;
scm_t_uint8 *u8vector;
size_t size;
SCM_VALIDATE_OBJCODE (1, objcode);

2
src/programs.c
View file

@ -205,7 +205,7 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
#define FUNC_NAME s_scm_program_bytecode
{
size_t size;
char *c_bytecode;
scm_t_uint8 *c_bytecode;
SCM_VALIDATE_PROGRAM (1, program);

2
src/vm.c
View file

@ -175,7 +175,7 @@ vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
frame = scm_c_make_heap_frame (fp);
fp = SCM_HEAP_FRAME_POINTER (frame);
SCM_FRAME_HEAP_LINK (fp) = link;
SCM_FRAME_DYNAMIC_LINK (fp) = SCM_HEAP_FRAME_POINTER (link);
SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
}
/* Move stack data */

12
src/vm_loader.c
View file

@ -63,7 +63,7 @@ VM_DEFINE_LOADER (load_number, "load-number")
size_t len;
FETCH_LENGTH (len);
PUSH (scm_string_to_number (scm_from_locale_stringn (ip, len),
PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
SCM_UNSPECIFIED /* radix = 10 */));
/* Was: scm_istring2number (ip, len, 10)); */
ip += len;
@ -74,7 +74,7 @@ VM_DEFINE_LOADER (load_string, "load-string")
{
size_t len;
FETCH_LENGTH (len);
PUSH (scm_from_locale_stringn (ip, len));
PUSH (scm_from_locale_stringn ((char *)ip, len));
/* Was: scm_makfromstr (ip, len, 0) */
ip += len;
NEXT;
@ -84,7 +84,7 @@ VM_DEFINE_LOADER (load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
PUSH (scm_from_locale_symboln (ip, len));
PUSH (scm_from_locale_symboln ((char *)ip, len));
ip += len;
NEXT;
}
@ -94,7 +94,7 @@ VM_DEFINE_LOADER (load_keyword, "load-keyword")
SCM sym;
size_t len;
FETCH_LENGTH (len);
sym = scm_from_locale_symboln (ip, len);
sym = scm_from_locale_symboln ((char *)ip, len);
PUSH (scm_make_keyword_from_dash_symbol (sym));
ip += len;
NEXT;
@ -104,7 +104,7 @@ VM_DEFINE_LOADER (load_module, "load-module")
{
size_t len;
FETCH_LENGTH (len);
PUSH (scm_c_lookup_env (scm_from_locale_symboln (ip, len)));
PUSH (scm_c_lookup_env (scm_from_locale_symboln ((char *)ip, len)));
ip += len;
NEXT;
}
@ -184,7 +184,7 @@ VM_DEFINE_LOADER (link, "link")
size_t len;
FETCH_LENGTH (len);
sym = scm_from_locale_symboln (ip, len);
sym = scm_from_locale_symboln ((char *)ip, len);
ip += len;
#if 0

36
testsuite/run-vm-tests.scm
View file

@ -1,14 +1,33 @@
;;; A simple test-running script.
;;; run-vm-tests.scm -- Run Guile-VM's test suite.
;;;
;;; Copyright 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
(use-modules (system vm core)
(system vm disasm)
(system base compile)
(system base language)
(srfi srfi-1))
(srfi srfi-1)
(ice-9 r5rs))
(define *scheme* (lookup-language 'scheme))
(define %scheme (lookup-language 'scheme))
(define (fetch-sexp-from-file file)
(with-input-from-file file
@ -21,13 +40,13 @@
(define (compile-to-objcode sexp)
"Compile the expression @var{sexp} into a VM program and return it."
(compile-in sexp (current-module) *scheme*))
(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)
(define (compile/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))))
@ -48,11 +67,16 @@ it succeeded."
;; The program.
(define (run-vm-tests files)
"For each file listed in @var{files}, load it and run it through both the
interpreter and the VM (after having it compiled). Both results must be
equal in the sense of @var{equal?}."
(let* ((res (map (lambda (file)
(format #t "running `~a'... " file)
(if (catch #t
(lambda ()
(run-test-from-file file))
(equal? (compile/run-test-from-file file)
(eval (fetch-sexp-from-file file)
(interaction-environment))))
(lambda (key . args)
(format #t "[~a/~a] " key args)
#f))

13
testsuite/t-closure.scm
View file

@ -1,5 +1,8 @@
(let ((x 2))
(lambda ()
(let ((x++ (+ 1 x)))
(set! x x++)
x++)))
(define func
(let ((x 2))
(lambda ()
(let ((x++ (+ 1 x)))
(set! x x++)
x++))))
(list (func) (func) (func))

2
testsuite/t-closure2.scm
View file

@ -6,3 +6,5 @@
(set! x x++)
x++))))
(do-uid)))
(list (uid) (uid) (uid))

2
testsuite/t-closure3.scm
View file

@ -3,3 +3,5 @@
(chbouib (lambda (z)
(+ 7 z x))))
(chbouib 77)))
(stuff)

2
testsuite/t-do-loop.scm
View file

@ -2,4 +2,4 @@
(do ((n- 5 (1- n-))
(n+ n+ (1+ n+)))
((= n- 0))
(format #t "n- = ~a~%" n-)))
(format #f "n- = ~a~%" n-)))

6
testsuite/t-proc-with-setter.scm
View file

@ -12,3 +12,9 @@
((first) (vector-set! struct 0 val))
((second) (vector-set! struct 1 val))
(else #f)))))
(and (eq? (vector-ref the-struct 0) (get/set the-struct 'first))
(eq? (vector-ref the-struct 1) (get/set the-struct 'second))
(begin
(set! (get/set the-struct 'second) 77)
(eq? (vector-ref the-struct 1) (get/set the-struct 'second))))