This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=74deff3c431245b282903d46eb7e571ace8759f3 The branch, master has been updated via 74deff3c431245b282903d46eb7e571ace8759f3 (commit) via d95eb7f49f721306ffeb0020724093929cb0e206 (commit) via 51e9ba2f38675ce5fd161b7df15470abaaf60e0e (commit) via 80545853d544f347ae991a476d78ccbf4d305ec7 (commit) via ccf77d955c875ce95473098af96da9e1bec0b7eb (commit) from 476e35728136b2d504855f3e2e4922ed72a41101 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 74deff3c431245b282903d46eb7e571ace8759f3 Author: Andy Wingo <[email protected]> Date: Fri Jul 24 12:06:40 2009 +0200 check that jumps are within the range of a signed 16-bit int * module/language/assembly/compile-bytecode.scm (write-bytecode): Check that the offset is within the range of a signed int16 value. commit d95eb7f49f721306ffeb0020724093929cb0e206 Author: Andy Wingo <[email protected]> Date: Fri Jul 24 12:06:19 2009 +0200 fix gensym creation in psyntax * module/ice-9/psyntax.scm (build-lexical-var): Make our gensyms really unique. Before, there was a chance that different lexicals could result in the same gensym. * module/ice-9/psyntax-pp.scm: Regenerate. commit 51e9ba2f38675ce5fd161b7df15470abaaf60e0e Author: Andy Wingo <[email protected]> Date: Fri Jul 24 12:05:54 2009 +0200 increase default stack size to 64 kilowords * libguile/vm.c (VM_DEFAULT_STACK_SIZE): Increase to 64 kilowords. Really, we should simply add overflow handlers, but in the meantime, this will do. commit 80545853d544f347ae991a476d78ccbf4d305ec7 Author: Andy Wingo <[email protected]> Date: Fri Jul 24 11:00:32 2009 +0200 compiler support for nlocs >= 256 * libguile/vm-i-system.c (long-local-ref, long-local-set) (make-variable): New intructions, for handling nlocs >= 256. * module/language/glil/compile-assembly.scm (glil->assembly): Compile <glil-lexical> with support for nlocs >= 256. commit ccf77d955c875ce95473098af96da9e1bec0b7eb Author: Andy Wingo <[email protected]> Date: Fri Jul 24 10:12:01 2009 +0200 nlocs is now 16 bits wide * libguile/objcodes.h (struct scm_objcode): Remove the "unused" field -- the old "nexts" -- and expand nlocs to 16 bits. * module/language/assembly/compile-bytecode.scm (write-bytecode): Write the nlocs as a uint16. * module/language/assembly/decompile-bytecode.scm (decode-load-program): Decompile 16-bit nlocs. It seems this decompilation is little-endian :-/ * test-suite/tests/asm-to-bytecode.test: Fix up to understand nlocs as a little-endian value. The test does the right thing regarding endianness. ----------------------------------------------------------------------- Summary of changes: libguile/objcodes.h | 3 +- libguile/vm-i-system.c | 28 +++++++++ libguile/vm.c | 2 +- module/ice-9/psyntax-pp.scm | 3 +- module/ice-9/psyntax.scm | 6 +- module/language/assembly/compile-bytecode.scm | 12 +++- module/language/assembly/decompile-bytecode.scm | 4 +- module/language/glil/compile-assembly.scm | 44 +++++++++++--- test-suite/tests/asm-to-bytecode.test | 73 ++++++++++++----------- 9 files changed, 119 insertions(+), 56 deletions(-) diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 6727e23..d50f6dc 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -25,8 +25,7 @@ struct scm_objcode { scm_t_uint8 nargs; scm_t_uint8 nrest; - scm_t_uint8 nlocs; - scm_t_uint8 unused; + scm_t_uint16 nlocs; scm_t_uint32 len; /* the maximum index of base[] */ scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of base[] for metadata */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index e12217e..c2c674d 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -278,6 +278,16 @@ VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1) NEXT; } +VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1) +{ + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + PUSH (LOCAL_REF (i)) + ASSERT_BOUND (*sp); + NEXT; +} + VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1) { SCM x = *sp; @@ -354,6 +364,16 @@ VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0) NEXT; } +VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0) +{ + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + LOCAL_SET (i, *sp); + DROP (); + NEXT; +} + VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0) { VARIABLE_SET (sp[0], sp[-1]); @@ -1183,6 +1203,14 @@ VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1) NEXT; } +VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1) +{ + SYNC_BEFORE_GC (); + /* fixme underflow */ + PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); + NEXT; +} + /* (defun renumber-ops () diff --git a/libguile/vm.c b/libguile/vm.c index 957baf6..41eacd7 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -325,7 +325,7 @@ resolve_variable (SCM what, SCM program_module) } -#define VM_DEFAULT_STACK_SIZE (16 * 1024) +#define VM_DEFAULT_STACK_SIZE (64 * 1024) #define VM_NAME vm_regular_engine #define FUNC_NAME "vm-regular-engine" diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 113269b..de0db95 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -54,7 +54,8 @@ (let ((id293 (if (syntax-object?99 id292) (syntax-object-expression100 id292) id292))) - (gensym (symbol->string id293))))) + (gensym + (string-append (symbol->string id293) " "))))) (strip161 (lambda (x294 w295) (if (memq (quote top) (wrap-marks118 w295)) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index f1f6e9a..6ecf24e 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -529,10 +529,10 @@ `(letrec ,(map list vars val-exps) ,body-exp) src)))))) -;; FIXME: wingo: use make-lexical ? +;; FIXME: use a faster gensym (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (gensym (symbol->string id))))) + ((_ src id) (gensym (string-append (symbol->string id) " "))))) (define-structure (syntax-object expression wrap module)) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index 0a14898..80dee83 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -77,10 +77,17 @@ ;; Ew! (for-each write-byte (bytevector->u8-list bv))) (define (write-break label) - (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) + (let ((offset (- (assq-ref labels label) (+ (get-addr) 2)))) + (cond ((>= offset (ash 1 15)) (error "jump too big" offset)) + ((< offset (- (ash 1 15))) (error "reverse jump too big" offset)) + (else (write-uint16-be offset))))) (let ((inst (car asm)) (args (cdr asm)) + (write-uint16 (case byte-order + ((1234) write-uint16-le) + ((4321) write-uint16-be) + (else (error "unknown endianness" byte-order)))) (write-uint32 (case byte-order ((1234) write-uint32-le) ((4321) write-uint32-be) @@ -92,8 +99,7 @@ ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) (write-byte nargs) (write-byte nrest) - (write-byte nlocs) - (write-byte 0) ;; what used to be nexts + (write-uint16 nlocs) (write-uint32 length) (write-uint32 (if meta (1- (byte-length meta)) 0)) (letrec ((i 0) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm index 56f58f7..231205d 100644 --- a/module/language/assembly/decompile-bytecode.scm +++ b/module/language/assembly/decompile-bytecode.scm @@ -48,8 +48,10 @@ x (- x (ash 1 16))))) +;; FIXME: this is a little-endian disassembly!!! (define (decode-load-program pop) - (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop)) + (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) + (nlocs (+ nlocs0 (ash nlocs1 8))) (a (pop)) (b (pop)) (c (pop)) (d (pop)) (e (pop)) (f (pop)) (g (pop)) (h (pop)) (len (+ a (ash b 8) (ash c 16) (ash d 24))) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index c7e26a8..9a5cae0 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -242,18 +242,42 @@ ((<glil-lexical> local? boxed? op index) (emit-code - `((,(if local? - (case op - ((ref) (if boxed? 'local-boxed-ref 'local-ref)) - ((set) (if boxed? 'local-boxed-set 'local-set)) - ((box) 'box) - ((empty-box) 'empty-box) - (else (error "what" op))) - (case op + (if local? + (if (< index 256) + `((,(case op + ((ref) (if boxed? 'local-boxed-ref 'local-ref)) + ((set) (if boxed? 'local-boxed-set 'local-set)) + ((box) 'box) + ((empty-box) 'empty-box) + (else (error "what" op))) + ,index)) + (let ((a (quotient i 256)) + (b (modulo i 256))) + `((,(case op + ((ref) + (if boxed? + `((long-local-ref ,a ,b) + (variable-ref)) + `((long-local-ref ,a ,b)))) + ((set) + (if boxed? + `((long-local-ref ,a ,b) + (variable-set)) + `((long-local-set ,a ,b)))) + ((box) + `((make-variable) + (variable-set) + (long-local-set ,a ,b))) + ((empty-box) + `((make-variable) + (long-local-set ,a ,b))) + (else (error "what" op))) + ,index)))) + `((,(case op ((ref) (if boxed? 'free-boxed-ref 'free-ref)) ((set) (if boxed? 'free-boxed-set (error "what." glil))) - (else (error "what" op)))) - ,index)))) + (else (error "what" op))) + ,index))))) ((<glil-toplevel> op name) (case op diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index d819a3b..fb598a6 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -20,16 +20,28 @@ #:use-module (system vm instruction) #:use-module (language assembly compile-bytecode)) +(define (->u8-list sym val) + (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) + (uint32 4 ,bytevector-u32-native-set!)) + sym))) + (or entry (error "unknown sym" sym)) + (let ((bv (make-bytevector (car entry)))) + ((cadr entry) bv 0 val) + (bytevector->u8-list bv)))) + (define (munge-bytecode v) - (let ((newv (make-u8vector (vector-length v)))) - (let lp ((i 0)) - (if (= i (vector-length v)) - newv - (let ((x (vector-ref v i))) - (u8vector-set! newv i (if (symbol? x) - (instruction->opcode x) - x)) - (lp (1+ i))))))) + (let lp ((i 0) (out '())) + (if (= i (vector-length v)) + (list->u8vector (reverse out)) + (let ((x (vector-ref v i))) + (cond + ((symbol? x) + (lp (1+ i) (cons (instruction->opcode x) out))) + ((integer? x) + (lp (1+ i) (cons x out))) + ((pair? x) + (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) + (else (error "bad test bytecode" x))))))) (define (comp-test x y) (let* ((y (munge-bytecode y)) @@ -46,13 +58,6 @@ (lambda () (equal? v y))))) -(define (u32->u8-list x) - ;; Return a 4 uint8 list corresponding to the host's native representation - ;; of X, a uint32. - (let ((bv (make-bytevector 4))) - (bytevector-u32-native-set! bv 0 x) - (bytevector->u8-list bv))) - (with-test-prefix "compiler" (with-test-prefix "asm-to-bytecode" @@ -86,28 +91,26 @@ (char->integer #\x))) (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - make-int8 3 - return))) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + make-int8 3 + return)) (comp-test '(load-program 3 2 1 () 3 (load-program 3 2 1 () 3 #f (make-int8 3) (return)) (make-int8 3) (return)) - (list->vector - `(load-program - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list (+ 3 12)) ;; metalen - make-int8 3 - return - 3 2 1 0 ;; nargs, nrest, nlocs, unused - ,@(u32->u8-list 3) ;; len - ,@(u32->u8-list 0) ;; metalen - make-int8 3 - return))))) + #(load-program + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 15) ;; metalen + make-int8 3 + return + 3 2 (uint16 1) ;; nargs, nrest, nlocs + (uint32 3) ;; len + (uint32 0) ;; metalen + make-int8 3 + return)))) hooks/post-receive -- GNU Guile
