make sure all programs are 8-byte aligned

* libguile/objcodes.c (OBJCODE_COOKIE): Bump objcode cookie, as we added
  to struct scm_objcode.
* libguile/objcodes.h (struct scm_objcode): Add a uint32 after metalen
  and before base, so that if the structure has 8-byte alignment, base
  will have 8-byte alignment too. (Before, base was 12 bytes from the
  start of the structure, now it's 16 bytes.)

* libguile/vm-engine.h (ASSERT_ALIGNED_PROCEDURE): Add a check that can
  be turned on with VM_ENABLE_PARANOID_ASSERTIONS.
  (CACHE_PROGRAM): Call ASSERT_ALIGNED_PROCEDURE.

* libguile/vm-i-system.c (long-local-ref): Add a missing semicolon.

* libguile/vm.c (really_make_boot_program): Rework to operate directly
  on a malloc'd buffer, so that the program will be 8-byte aligned.

* module/language/assembly.scm (*program-header-len*): Add another 4 for
  the padding.
  (object->assembly): Fix case in which we would return (make-int8 0)
  instead of (make-int8:0). This would throw off compile-assembly.scm's
  use of addr+.

* module/language/assembly/compile-bytecode.scm (write-bytecode): Write
  out the padding int.

* module/language/assembly/decompile-bytecode.scm (decode-load-program):
  And pop off the padding int too.

* module/language/glil/compile-assembly.scm (glil->assembly): Don't pack
  the assembly, assume that assembly.scm has done it for us. If a
  program has a meta, pad out the program so that meta will be aligned.

* test-suite/tests/asm-to-bytecode.test: Adapt to expect programs to
  have the extra 4-byte padding int.

libguile/objcodes.c

@@ -50,7 +50,7 @@
 
 /* The objcode magic header.  */
 #define OBJCODE_COOKIE						\
-  "GOOF-0.7-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
+  "GOOF-0.8-" 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/objcodes.h

@@ -29,6 +29,7 @@ struct scm_objcode {
   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 */
+  scm_t_uint32 unused;          /* pad so that `base' is 8-byte aligned */
   scm_t_uint8 base[0];
 };
 

libguile/vm-engine.h

@@ -130,11 +130,14 @@
 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
 #define CHECK_IP() \
   do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_ALIGNED_PROCEDURE() \
+  do { if ((scm_t_bits)bp % 8) abort (); } while (0)
 #define ASSERT_BOUND(x) \
   do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
   } while (0)
 #else
 #define CHECK_IP()
+#define ASSERT_ALIGNED_PROCEDURE()
 #define ASSERT_BOUND(x)
 #endif
 
@@ -143,6 +146,7 @@
 {									\
   if (bp != SCM_PROGRAM_DATA (program)) {                               \
     bp = SCM_PROGRAM_DATA (program);					\
+    ASSERT_ALIGNED_PROCEDURE ();                                        \
     if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
       objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
       object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \

libguile/vm-i-system.c

@@ -283,7 +283,7 @@ 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))
+  PUSH (LOCAL_REF (i));
   ASSERT_BOUND (*sp);
   NEXT;
 }

libguile/vm.c

@@ -220,44 +220,33 @@ static SCM sym_vm_run;
 static SCM sym_vm_error;
 static SCM sym_debug;
 
-static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
-{
-  scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
-  memcpy (new_bytes, bytes, len);
-  return scm_take_u8vector (new_bytes, len);
-}
-
-/* Dummy structure to guarantee 32-bit alignment.  */
-struct t_32bit_aligned
-{
-  scm_t_int32 dummy;
-  scm_t_uint8 bytes[18];
-};
-
 static SCM
 really_make_boot_program (long nargs)
 {
   SCM u8vec;
-  struct t_32bit_aligned bytes =
+  /* Make sure "bytes" is 64-bit aligned.  */
-    {
+  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
-      .dummy = 0,
+                         scm_op_make_int8_1,
-      .bytes = { 0, 0, 0, 0,
+                         scm_op_halt };
-		 0, 0, 0, 0,
+  struct scm_objcode *bp;
-		 0, 0, 0, 0,
-		 scm_op_mv_call, 0, 0, 1,
-		 scm_op_make_int8_1, scm_op_halt }
-    };
-
   SCM ret;
 
-  /* Set length in current endianness, no meta.  */
-  ((scm_t_uint32 *) bytes.bytes)[1] = 6;
-
   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
     abort ();
-  bytes.bytes[13] = (scm_byte_t) nargs;
+  text[1] = (scm_t_uint8)nargs;
 
-  u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes));
+  bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
+                      "make-u8vector");
+  memcpy (bp->base, text, sizeof (text));
+  bp->nargs = 0;
+  bp->nrest = 0;
+  bp->nlocs = 0;
+  bp->len = sizeof(text);
+  bp->metalen = 0;
+  bp->unused = 0;
+
+  u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
+                             sizeof (struct scm_objcode) + sizeof (text));
   ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
                           SCM_BOOL_F, SCM_BOOL_F);
   SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);

module/language/assembly.scm

@@ -28,8 +28,8 @@
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
-;; nargs, nrest, nlocs, <unused>, len, metalen
+;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 1 1 4 4))
+(define *program-header-len* (+ 1 1 2 4 4 4))
 
 ;; lengths are encoded in 3 bytes
 (define *len-len* 3)
@@ -109,7 +109,7 @@
 	((null? x) `(make-eol))
 	((and (integer? x) (exact? x))
 	 (cond ((and (<= -128 x) (< x 128))
-		`(make-int8 ,(modulo x 256)))
+		(assembly-pack `(make-int8 ,(modulo x 256))))
 	       ((and (<= -32768 x) (< x 32768))
 		(let ((n (if (< x 0) (+ x 65536) x)))
 		  `(make-int16 ,(quotient n 256) ,(modulo n 256))))

module/language/assembly/compile-bytecode.scm

@@ -102,6 +102,7 @@
          (write-uint16 nlocs)
          (write-uint32 length)
          (write-uint32 (if meta (1- (byte-length meta)) 0))
+         (write-uint32 0) ; padding
          (letrec ((i 0)
                   (write (lambda (x) (set! i (1+ i)) (write-byte x)))
                   (get-addr (lambda () i)))

module/language/assembly/decompile-bytecode.scm

@@ -57,6 +57,7 @@
          (len (+ a (ash b 8) (ash c 16) (ash d 24)))
          (metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
          (totlen (+ len metalen))
+         (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
          (labels '())
          (i 0))
     (define (ensure-label rel1 rel2)

module/language/glil/compile-assembly.scm

@@ -137,9 +137,9 @@
 (define (glil->assembly glil toplevel? bindings
                         source-alist label-alist object-alist addr)
   (define (emit-code x)
-    (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+    (values x bindings source-alist label-alist object-alist))
   (define (emit-code/object x object-alist)
-    (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+    (values x bindings source-alist label-alist object-alist))
 
   (record-case glil
     ((<glil-program> nargs nrest nlocs meta body)
@@ -164,10 +164,15 @@
 
      (receive (code bindings sources labels objects len)
          (process-body)
-       (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
+       (let* ((meta (make-meta bindings sources meta))
-                                  ,len
+              (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
-                                  ,(make-meta bindings sources meta)
+              (prog `(load-program ,nargs ,nrest ,nlocs ,labels
-                                  . ,code)))
+                                  ,(+ len meta-pad)
+                                  ,meta
+                                  ,@code
+                                  ,@(if meta
+                                        (make-list meta-pad '(nop))
+                                        '()))))
          (cond
           (toplevel?
            ;; toplevel bytecode isn't loaded by the vm, no way to do

test-suite/tests/asm-to-bytecode.test

@@ -95,22 +95,29 @@
                  3 2 (uint16 1) ;; nargs, nrest, nlocs
                  (uint32 3)     ;; len
                  (uint32 0)     ;; metalen
+                 (uint32 0)     ;; padding
                  make-int8 3
                  return))
 
-    (comp-test '(load-program 3 2 1 () 3
+    ;; the nops are to pad meta to an 8-byte alignment. not strictly
+    ;; necessary for this test, but representative of the common case.
+    (comp-test '(load-program 3 2 1 () 8
                               (load-program 3 2 1 () 3
                                             #f
                                             (make-int8 3) (return))
-                              (make-int8 3) (return))
+                              (make-int8 3) (return)
+                              (nop) (nop) (nop) (nop) (nop))
                #(load-program
                  3 2 (uint16 1) ;; nargs, nrest, nlocs
-                 (uint32 3)     ;; len
+                 (uint32 8)     ;; len
-                 (uint32 15)    ;; metalen
+                 (uint32 19)    ;; metalen
+                 (uint32 0)     ;; padding
                  make-int8 3
                  return
+                 nop nop nop nop nop
                  3 2 (uint16 1) ;; nargs, nrest, nlocs
                  (uint32 3)     ;; len
                  (uint32 0)     ;; metalen
+                 (uint32 0)     ;; padding
                  make-int8 3
                  return))))