increase range of relative jumps by aligning blocks to 8-byte boundaries

* libguile/objcodes.c (OBJCODE_COOKIE): Bump again, as our jump offsets
  are now multiplied by 8.

* libguile/vm-i-system.c (BR): Interpret the 16-bit offset as a relative
  jump to the nearest 8-byte-aligned block -- increasing relative jump
  range from +/-32K to +/-240K.
  (mvra): Do the same for the mvra jump.

* libguile/vm.c (really_make_boot_program): Align the mvra.

* module/language/assembly.scm (align-block): New export, for aligning
  blocks.

* module/language/assembly/compile-bytecode.scm (write-bytecode): Emit
  jumps to the nearest 8-byte-aligned block. Effectively our range is 18
  bits in either direction. I would like to do this differently -- have
  long-br and long-br-if, and all the other br instructions go to 8 bits
  only. But the assembler doesn't have an appropriate representation to
  allow me to do this yet, so for now this is what we have.

* module/language/assembly/decompile-bytecode.scm (decode-load-program):
  Decode the 19-bit jumps.

libguile/objcodes.c

@@ -50,7 +50,7 @@
 
 /* The objcode magic header.  */
 #define OBJCODE_COOKIE						\
-  "GOOF-0.8-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
+  "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
 
 /* The length of the header must be a multiple of 8 bytes.  */
 verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0);

libguile/vm-i-system.c

@@ -426,7 +426,7 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
  * branch and jump
  */
 
-/* offset must be a signed short!!! */
+/* offset must be a signed 16 bit int!!! */
 #define FETCH_OFFSET(offset)                    \
 {						\
   int h = FETCH ();				\
@@ -436,10 +436,10 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
 
 #define BR(p)					\
 {						\
-  signed short offset;                          \
+  scm_t_int16 offset;                           \
   FETCH_OFFSET (offset);                        \
   if (p)					\
-    ip += offset;				\
+    ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);      \
   NULLSTACK (1);				\
   DROP ();					\
   NEXT;						\
@@ -447,9 +447,9 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
 
 VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
 {
-  int h = FETCH ();
+  scm_t_int16 offset;
-  int l = FETCH ();
+  FETCH_OFFSET (offset);
-  ip += (signed short) (h << 8) + l;
+  ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
   NEXT;
 }
 
@@ -812,10 +812,12 @@ VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
 VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
 {
   SCM x;
-  signed short offset;
+  scm_t_int16 offset;
+  scm_t_uint8 *mvra;
   
   nargs = FETCH ();
   FETCH_OFFSET (offset);
+  mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
 
   x = sp[-nargs];
 
@@ -828,7 +830,7 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
       CACHE_PROGRAM ();
       INIT_ARGS ();
       NEW_FRAME ();
-      SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+      SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
       ENTER_HOOK ();
       APPLY_HOOK ();
       NEXT;
@@ -853,7 +855,7 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
           len = scm_length (values);
           PUSH_LIST (values, SCM_NULLP);
           PUSH (len);
-          ip += offset;
+          ip = mvra;
         }
       NEXT;
     }

libguile/vm.c

@@ -226,7 +226,7 @@ really_make_boot_program (long nargs)
   SCM u8vec;
   /* Make sure "bytes" is 64-bit aligned.  */
   scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
-                         scm_op_make_int8_1,
+                         scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
                          scm_op_halt };
   struct scm_objcode *bp;
   SCM ret;

module/language/assembly.scm

@@ -24,7 +24,7 @@
   #:use-module (system vm instruction)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export (byte-length
-            addr+ align-program align-code
+            addr+ align-program align-code align-block
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
@@ -63,17 +63,24 @@
 
 (define *program-alignment* 8)
 
+(define *block-alignment* 8)
+
 (define (addr+ addr code)
   (fold (lambda (x len) (+ (byte-length x) len))
         addr
         code))
 
+(define (code-alignment addr alignment header-len)
+  (make-list (modulo (- alignment
+                        (modulo (+ addr header-len) alignment))
+                     alignment)
+             '(nop)))
+
+(define (align-block addr)
+  (code-alignment addr *block-alignment* 0))
 
 (define (align-code code addr alignment header-len)
-  `(,@(make-list (modulo (- alignment
+  `(,@(code-alignment addr alignment header-len)
-                            (modulo (+ addr header-len) alignment))
-                         alignment)
-                 '(nop))
     ,code))
 
 (define (align-program prog addr)

module/language/assembly/compile-bytecode.scm

@@ -77,10 +77,12 @@
     ;; Ew!
     (for-each write-byte (bytevector->u8-list bv)))
   (define (write-break label)
-    (let ((offset (- (assq-ref labels label) (+ (get-addr) 2))))
+    (let ((offset (- (assq-ref labels label)
-      (cond ((>= offset (ash 1 15)) (error "jump too big" offset))
+                     (logand (+ (get-addr) 2) (lognot #x7)))))
-            ((< offset (- (ash 1 15))) (error "reverse jump too big" offset))
+      (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
-            (else (write-uint16-be 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 ((inst (car asm))
         (args (cdr asm))

module/language/assembly/decompile-bytecode.scm

@@ -61,7 +61,8 @@
          (labels '())
          (i 0))
     (define (ensure-label rel1 rel2)
-      (let ((where (+ i (bytes->s16 rel1 rel2))))
+      (let ((where (+ (logand i (lognot #x7))
+                      (* (bytes->s16 rel1 rel2) 8))))
         (or (assv-ref labels where)
             (begin
               (let ((l (gensym ":L")))

module/language/glil/compile-assembly.scm

@@ -340,11 +340,12 @@
           (error "unknown module var kind" op key)))))
 
     ((<glil-label> label)
-     (values '()
+     (let ((code (align-block addr)))
-             bindings
+       (values code
-             source-alist
+               bindings
-             (acons label addr label-alist)
+               source-alist
-             object-alist))
+               (acons label (addr+ addr code) label-alist)
+               object-alist)))
 
     ((<glil-branch> inst label)
      (emit-code `((,inst ,label))))