jumps encoded using 24 bits, not 19; blocks no longer aligned

* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
* libguile/vm-i-system.c (FETCH_OFFSET, BR): Labels are no longer 8-byte
  aligned; instead, jumps are encoded into 3 bytes instead of 2.
  (br, br-if, br-if-not, br-if-eq, br-if-not-eq, br-if-null)
  (br-if-not-null, mv-call): Adapt for new length of br instructions (3
  bytes instead of 2).

* libguile/vm.c (really_make_boot_program): Adapt hand-coded bytecode
  for new offset regime.

* module/language/assembly.scm (align-block): No alignment necessary.

* module/language/assembly/compile-bytecode.scm (write-bytecode): Write
  out breaks as 24-bit relative jumps.
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
  Decompile break instructions.

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        \

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 ();				\
+  offset = FETCH () << 16;                      \
-  int l = FETCH ();				\
+  offset += FETCH () << 8;                      \
-  offset = (h << 8) + l;                        \
+  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];
 

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_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
-                         scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
+                         scm_op_make_int8_1, scm_op_halt };
-                         scm_op_halt };
   struct scm_objcode *bp;
   SCM ret;
 

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)

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)
+    (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
-                     (logand (+ (get-addr) 2) (lognot #x7)))))
+      (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
-      (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
+            ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
-            ((>= offset (ash 1 18)) (error "jump too far forward" offset))
+            (else (write-uint24-be offset)))))
-            ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
-            (else (write-uint16-be (ash offset -3))))))
   
   (let ((inst (car asm))
         (args (cdr asm))

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)
+(define (bytes->s24 a b c)
-  (let ((x (+ (ash a 8) b)))
+  (let ((x (+ (ash a 16) (ash b 8) c)))
-    (if (zero? (logand (ash 1 15) x))
+    (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)
+    (define (ensure-label rel1 rel2 rel3)
-      (let ((where (+ (logand i (lognot #x7))
+      (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
-                      (* (bytes->s16 rel1 rel2) 8))))
         (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))
+                 ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
-                  (lp (cons `(,br ,(ensure-label rel1 rel2)) out)))
+                  (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
-                 ((mv-call ,n ,rel1 ,rel2)
+                 ((mv-call ,n ,rel1 ,rel2 ,rel3)
                   (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out)))
                  (else 
                   (lp (cons exp out))))))))))