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-4-8-gcbeb


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-4-8-gcbeb479
Date: Fri, 16 Oct 2009 14:03:50 +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=cbeb479c6e4da67ef37efa2548713fd6eadc71f3

The branch, master has been updated
       via  cbeb479c6e4da67ef37efa2548713fd6eadc71f3 (commit)
       via  97fcf583b7239ea17dbb73eae9438d21136eb2db (commit)
      from  f95f82f8e183f2744740bdc950dba9c856e09094 (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 -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 libguile/_scm.h                                 |    2 +-
 libguile/vm-i-system.c                          |   37 ++++++++++++-----------
 libguile/vm.c                                   |    5 +--
 module/language/assembly.scm                    |    2 +-
 module/language/assembly/compile-bytecode.scm   |   14 +++++----
 module/language/assembly/decompile-bytecode.scm |   19 +++++------
 module/language/tree-il/compile-glil.scm        |    6 ----
 7 files changed, 40 insertions(+), 45 deletions(-)

diff --git a/libguile/_scm.h b/libguile/_scm.h
index 8a9a211..6aedebe 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -172,7 +172,7 @@
 
 /* Major and minor versions must be single characters. */
 #define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION D
+#define SCM_OBJCODE_MINOR_VERSION E
 #define SCM_OBJCODE_MAJOR_VERSION_STRING        \
   SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
 #define SCM_OBJCODE_MINOR_VERSION_STRING        \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 0662f81..ac237e5 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -411,61 +411,62 @@ VM_DEFINE_INSTRUCTION (30, long_toplevel_set, 
"long-toplevel-set", 2, 1, 0)
  * branch and jump
  */
 
-/* offset must be a signed 16 bit int!!! */
+/* offset must be at least 24 bits wide, and signed */
 #define FETCH_OFFSET(offset)                    \
 {                                              \
-  int h = FETCH ();                            \
-  int l = FETCH ();                            \
-  offset = (h << 8) + l;                        \
+  offset = FETCH () << 16;                      \
+  offset += FETCH () << 8;                      \
+  offset += FETCH ();                           \
+  offset -= (offset & (1<<23)) << 1;            \
 }
 
 #define BR(p)                                  \
 {                                              \
-  scm_t_int16 offset;                           \
+  scm_t_int32 offset;                           \
   FETCH_OFFSET (offset);                        \
   if (p)                                       \
-    ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);      \
+    ip += offset;                               \
   NULLSTACK (1);                               \
   DROP ();                                     \
   NEXT;                                                \
 }
 
-VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (31, br, "br", 3, 0, 0)
 {
-  scm_t_int16 offset;
+  scm_t_int32 offset;
   FETCH_OFFSET (offset);
-  ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
+  ip += offset;
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 3, 0, 0)
 {
   BR (!SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 3, 0, 0)
 {
   BR (SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 3, 0, 0)
 {
   sp--; /* underflow? */
   BR (SCM_EQ_P (sp[0], sp[1]));
 }
 
-VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
 {
   sp--; /* underflow? */
   BR (!SCM_EQ_P (sp[0], sp[1]));
 }
 
-VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 3, 0, 0)
 {
   BR (SCM_NULLP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 3, 0, 0)
 {
   BR (!SCM_NULLP (*sp));
 }
@@ -642,15 +643,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 
0, 1)
   goto vm_call;
 }
 
-VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
 {
   SCM x;
-  scm_t_int16 offset;
+  scm_t_int32 offset;
   scm_t_uint8 *mvra;
   
   nargs = FETCH ();
   FETCH_OFFSET (offset);
-  mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
+  mvra = ip + offset;
 
   x = sp[-nargs];
 
diff --git a/libguile/vm.c b/libguile/vm.c
index d41c8cd..cd73051 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -180,9 +180,8 @@ static SCM
 really_make_boot_program (long nargs)
 {
   SCM u8vec;
-  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
-                         scm_op_make_int8_1, scm_op_nop, scm_op_nop, 
scm_op_nop,
-                         scm_op_halt };
+  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
+                         scm_op_make_int8_1, scm_op_halt };
   struct scm_objcode *bp;
   SCM ret;
 
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 683da6c..2b22fd8 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -72,7 +72,7 @@
              '(nop)))
 
 (define (align-block addr)
-  (code-alignment addr *block-alignment* 0))
+  '())
 
 (define (align-code code addr alignment header-len)
   `(,@(code-alignment addr alignment header-len)
diff --git a/module/language/assembly/compile-bytecode.scm 
b/module/language/assembly/compile-bytecode.scm
index e8bba9e..5a80981 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -55,6 +55,10 @@
   (define (write-uint16-le x)
     (write-byte (logand x 255))
     (write-byte (logand (ash x -8) 255)))
+  (define (write-uint24-be x)
+    (write-byte (logand (ash x -16) 255))
+    (write-byte (logand (ash x -8) 255))
+    (write-byte (logand x 255)))
   (define (write-uint32-be x)
     (write-byte (logand (ash x -24) 255))
     (write-byte (logand (ash x -16) 255))
@@ -85,12 +89,10 @@
     ;; Ew!
     (for-each write-byte (bytevector->u8-list bv)))
   (define (write-break label)
-    (let ((offset (- (assq-ref labels label)
-                     (logand (+ (get-addr) 2) (lognot #x7)))))
-      (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
-            ((>= offset (ash 1 18)) (error "jump too far forward" offset))
-            ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
-            (else (write-uint16-be (ash offset -3))))))
+    (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+      (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+            ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
+            (else (write-uint24-be offset)))))
   
   (let ((inst (car asm))
         (args (cdr asm))
diff --git a/module/language/assembly/decompile-bytecode.scm 
b/module/language/assembly/decompile-bytecode.scm
index 511c6cc..915e101 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -43,11 +43,11 @@
 (define (br-instruction? x)
   (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null 
br-if-not-null)))
 
-(define (bytes->s16 a b)
-  (let ((x (+ (ash a 8) b)))
-    (if (zero? (logand (ash 1 15) x))
+(define (bytes->s24 a b c)
+  (let ((x (+ (ash a 16) (ash b 8) c)))
+    (if (zero? (logand (ash 1 23) x))
         x
-        (- x (ash 1 16)))))
+        (- x (ash 1 24)))))
 
 ;; FIXME: this is a little-endian disassembly!!!
 (define (decode-load-program pop)
@@ -60,9 +60,8 @@
          (%unused-pad (begin (pop) (pop) (pop) (pop)))
          (labels '())
          (i 0))
-    (define (ensure-label rel1 rel2)
-      (let ((where (+ (logand i (lognot #x7))
-                      (* (bytes->s16 rel1 rel2) 8))))
+    (define (ensure-label rel1 rel2 rel3)
+      (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
         (or (assv-ref labels where)
             (begin
               (let ((l (gensym ":L")))
@@ -87,9 +86,9 @@
             (else
              (let ((exp (decode-bytecode sub-pop)))
                (pmatch exp
-                 ((,br ,rel1 ,rel2) (guard (br-instruction? br))
-                  (lp (cons `(,br ,(ensure-label rel1 rel2)) out)))
-                 ((mv-call ,n ,rel1 ,rel2)
+                 ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
+                  (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
+                 ((mv-call ,n ,rel1 ,rel2 ,rel3)
                   (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out)))
                  (else 
                   (lp (cons exp out))))))))))
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 4ab03bf..94e1904 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -30,11 +30,6 @@
   #:use-module (language tree-il analyze)
   #:export (compile-glil))
 
-;;; TODO:
-;;
-;; call-with-values -> mv-bind
-;; basic degenerate-case reduction
-
 ;; allocation:
 ;;  sym -> {lambda -> address}
 ;;  lambda -> (nlocs labels . free-locs)
@@ -164,7 +159,6 @@
        ids
        vars))
 
-;; FIXME: always emit? otherwise it's hard to pair bind with unbind
 (define (emit-bindings src ids vars allocation proc emit-code)
   (emit-code src (make-glil-bind
                   (vars->bind-list ids vars allocation proc))))


hooks/post-receive
-- 
GNU Guile




reply via email to

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