guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-11-g74d


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-1-11-g74deff3
Date: Fri, 24 Jul 2009 11:07:07 +0000

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




reply via email to

[Prev in Thread] Current Thread [Next in Thread]