add code for writing out metadata to the end of a program

* libguile/objcodes.c (make_objcode_by_mmap, scm_c_make_objcode_slice):
  Verify the lengths with the meta-length.
  (scm_objcode_meta): New procedure, for getting at the meta-info of an
  objcode.
  (scm_objcode_to_bytecode):
  (scm_write_objcode): Write bytecode with the metadata too.

* module/system/vm/objcode.scm: Export object-meta.

* module/language/assembly.scm (byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
* module/language/glil/compile-assembly.scm (glil->assembly):
* test-suite/tests/asm-to-bytecode.test ("compiler"): Change to
  load-program format to have meta-or-#f instead of meta-length, so that
  we can serialize the meta as objcode without a load-program byte. Add a
  test for writing out the meta.

libguile/objcodes.c

@@ -92,10 +92,10 @@ make_objcode_by_mmap (int fd)
 
   data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
 
-  if (data->len != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+  if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
     scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
 		    SCM_LIST2 (scm_from_size_t (st.st_size),
-                               scm_from_uint32 (data->len)));
+                               scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
 
   SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
                 SCM_PACK (SCM_BOOL_F), fd);
@@ -118,14 +118,16 @@ scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
   parent_data = SCM_OBJCODE_DATA (parent);
   
   if (ptr < parent_data->base
-      || ptr >= (parent_data->base + parent_data->len
+      || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
                  - sizeof (struct scm_objcode)))
-    scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a)",
+    scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
-		    SCM_LIST2 (scm_from_ulong ((ulong)ptr),
+		    SCM_LIST4 (scm_from_ulong ((ulong)ptr),
-                               scm_from_uint32 (parent_data->len)));
+                               scm_from_ulong ((ulong)parent_data->base),
+                               scm_from_uint32 (parent_data->len),
+                               scm_from_uint32 (parent_data->metalen)));
 
   data = (struct scm_objcode*)ptr;
-  if (data->base + data->len > parent_data->base + parent_data->len)
+  if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
     abort ();
 
   SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
@@ -154,6 +156,21 @@ SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_meta
+{
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  if (SCM_OBJCODE_META_LEN (objcode) == 0)
+    return SCM_BOOL_F;
+  else
+    return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+                                               + SCM_OBJCODE_LEN (objcode)));
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
 	    (SCM bytecode),
 	    "")
@@ -180,6 +197,7 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
   
   /* foolishly, we assume that as long as bytecode is around, that c_bytecode
      will be of the same length; perhaps a bad assumption? */
+  /* FIXME: check length of bytecode */
 
   return objcode;
 }
@@ -214,7 +232,7 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
 
   SCM_VALIDATE_OBJCODE (1, objcode);
 
-  len = SCM_OBJCODE_DATA (objcode)->len + sizeof(struct scm_objcode);
+  len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
   /* FIXME:  Is `gc_malloc' ok here? */
   u8vector = scm_gc_malloc (len, "objcode-u8vector");
   memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
@@ -233,7 +251,7 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
   
   scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
   scm_c_write (port, SCM_OBJCODE_DATA (objcode),
-               SCM_OBJCODE_LEN (objcode) + sizeof (struct scm_objcode));
+               sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
 
   return SCM_UNSPECIFIED;
 }

libguile/objcodes.h

@@ -82,6 +82,7 @@ extern scm_t_bits scm_tc16_objcode;
 SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
 extern SCM scm_load_objcode (SCM file);
 extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_objcode_meta (SCM objcode);
 extern SCM scm_bytecode_to_objcode (SCM bytecode);
 extern SCM scm_objcode_to_bytecode (SCM objcode);
 extern SCM scm_write_objcode (SCM objcode, SCM port);

module/language/assembly.scm

@@ -48,8 +48,8 @@
      (+ 1 *len-len* (string-length str)))
     ((define ,str)
      (+ 1 *len-len* (string-length str)))
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
-     (+ 1 *program-header-len* len metalen))
+     (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (+ 1 (instruction-length inst)))
     (else (error "unknown instruction" assembly))))

module/language/assembly/compile-bytecode.scm

@@ -81,19 +81,27 @@
       (write-byte opcode)
       (pmatch asm
         ((load-program ,nargs ,nrest ,nlocs ,nexts
-                       ,labels ,length ,metalength . ,code)
+                       ,labels ,length ,meta . ,code)
          (write-byte nargs)
          (write-byte nrest)
          (write-byte nlocs)
          (write-byte nexts)
          (write-uint32-le length) ;; FIXME!
-         (write-uint32-le metalength) ;; FIXME!
+         (write-uint32-le (if meta (1- (byte-length meta)) 0)) ;; FIXME!
          (letrec ((i 0)
                   (write (lambda (x) (set! i (1+ i)) (write-byte x)))
                   (get-addr (lambda () i)))
            (for-each (lambda (asm)
                        (write-bytecode asm write get-addr labels))
-                     code)))
+                     code))
+         (if meta
+             ;; don't write the load-program byte for metadata
+             (letrec ((i -1)
+                      (write (lambda (x)
+                               (set! i (1+ i))
+                               (if (> i 0) (write-byte x))))
+                      (get-addr (lambda () i)))
+               (write-bytecode meta write get-addr '()))))
         ((load-integer ,str) (write-loader str))
         ((load-number ,str) (write-loader str))
         ((load-string ,str) (write-loader str))

module/language/assembly/decompile-bytecode.scm

@@ -48,16 +48,17 @@
          (totlen (+ len metalen))
          (i 0))
     (define (sub-pop) ;; ...records. ha. ha.
-      (let ((b (cond ((< i totlen) (pop))
+      (let ((b (cond ((< i len) (pop))
-                     ((= i totlen) #f)
+                     ((= i len) #f)
                      (else (error "tried to decode too many bytes")))))
         (if b (set! i (1+ i)))
         b))
     (let lp ((out '()))
-      (cond ((> i totlen)
+      (cond ((> i len)
              (error "error decoding program -- read too many bytes" out))
-            ((= i totlen)
+            ((= i len)
-             `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len ,metalen
+             `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len
+                            ,(if (zero? metalen) #f (decode-load-program pop))
                             ,@(reverse! out)))
             (else
              (let ((exp (decode-bytecode sub-pop)))

module/language/assembly/disassemble.scm

@@ -36,7 +36,7 @@
 
 (define (disassemble-load-program asm env)
   (pmatch asm
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
      (let ((objs  (and env (assq-ref env 'objects)))
            (meta  (and env (assq-ref env 'meta)))
            (exts  (and env (assq-ref env 'exts)))

module/language/glil/compile-assembly.scm

@@ -151,7 +151,7 @@
        (receive (code bindings sources labels objects len)
            (process-body)
          (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
-                                    ,len 0 . ,code)))
+                                    ,len #f . ,code)))
            (cond
             (toplevel?
              ;; toplevel bytecode isn't loaded by the vm, no way to do

module/system/vm/objcode.scm

@@ -20,7 +20,8 @@
 ;;; Code:
 
 (define-module (system vm objcode)
-  #:export (objcode? bytecode->objcode objcode->bytecode
+  #:export (objcode? objcode-meta
+            bytecode->objcode objcode->bytecode
             load-objcode write-objcode
             word-size byte-order))
 

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

@@ -77,7 +77,20 @@
                        (char->integer #\x)))
     
     ;; fixme: little-endian test.
-    (comp-test '(load-program 3 2 1 0 '() 3 0 (make-int8 3) (return))
+    (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
                (vector 'load-program 3 2 1 0 3 0 0 0 0 0 0 0
+                       (instruction->opcode 'make-int8) 3
+                       (instruction->opcode 'return)))
+
+    ;; fixme: little-endian test.
+    (comp-test '(load-program 3 2 1 0 () 3
+                              (load-program 3 2 1 0 () 3
+                                            #f
+                                            (make-int8 3) (return))
+                              (make-int8 3) (return))
+               (vector 'load-program 3 2 1 0 3 0 0 0 (+ 3 12) 0 0 0
+                       (instruction->opcode 'make-int8) 3
+                       (instruction->opcode 'return)
+                       3 2 1 0 3 0 0 0 0 0 0 0
                        (instruction->opcode 'make-int8) 3
                        (instruction->opcode 'return)))))