add metalen field to bytecode serialization

* libguile/objcodes.h (struct scm_objcode): Add a new field, metalen, in
  preparation for embedding metadata within a program.
  (SCM_OBJCODE_META_LEN, SCM_OBJCODE_TOTAL_LEN): New defines.

* libguile/vm.c (really_make_boot_program):
* module/language/assembly.scm (*program-header-len*, 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"): Update for metalen
  addition.

diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 6b3c2ae..7480a03 100644 (file)
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -51,6 +51,8 @@ struct scm_objcode {
   scm_t_uint8 nlocs;
   scm_t_uint8 nexts;
   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_uint8 base[0];
 };
 
@@ -65,6 +67,8 @@ extern scm_t_bits scm_tc16_objcode;
 #define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
 
 #define SCM_OBJCODE_LEN(x)     (SCM_OBJCODE_DATA (x)->len)
+#define SCM_OBJCODE_META_LEN(x)        (SCM_OBJCODE_DATA (x)->metalen)
+#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
 #define SCM_OBJCODE_NARGS(x)   (SCM_OBJCODE_DATA (x)->nargs)
 #define SCM_OBJCODE_NREST(x)   (SCM_OBJCODE_DATA (x)->nrest)
 #define SCM_OBJCODE_NLOCS(x)   (SCM_OBJCODE_DATA (x)->nlocs)

diff --git a/libguile/vm.c b/libguile/vm.c
index 9e5e9db..ffb1438 100644 (file)
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -271,12 +271,13 @@ static SCM
 really_make_boot_program (long nargs)
 {
   scm_byte_t bytes[] = {0, 0, 0, 0,
+                        0, 0, 0, 0,
                         0, 0, 0, 0,
                         scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
-  ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness */
+  ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
   if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
     abort ();
-  bytes[9] = (scm_byte_t)nargs;
+  bytes[13] = (scm_byte_t)nargs;
   return scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
                            SCM_BOOL_F, SCM_EOL);
 }

diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index b124081..8887eab 100644 (file)
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -26,8 +26,8 @@
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
-;; nargs, nrest, nlocs, nexts, len
-(define *program-header-len* (+ 1 1 1 1 4))
+;; nargs, nrest, nlocs, nexts, len, metalen
+(define *program-header-len* (+ 1 1 1 1 4 4))
 
 ;; lengths are encoded in 3 bytes
 (define *len-len* 3)
@@ -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 . ,code)
-     (+ 1 *program-header-len* len))
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
+     (+ 1 *program-header-len* len metalen))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (+ 1 (instruction-length inst)))
     (else (error "unknown instruction" assembly))))

diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 17a71f2..bf423ab 100644 (file)
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -81,12 +81,13 @@
       (write-byte opcode)
       (pmatch asm
         ((load-program ,nargs ,nrest ,nlocs ,nexts
-                       ,labels ,length . ,code)
+                       ,labels ,length ,metalength . ,code)
          (write-byte nargs)
          (write-byte nrest)
          (write-byte nlocs)
          (write-byte nexts)
          (write-uint32-le length) ;; FIXME!
+         (write-uint32-le metalength) ;; FIXME!
          (letrec ((i 0)
                   (write (lambda (x) (set! i (1+ i)) (write-byte x)))
                   (get-addr (lambda () i)))

diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index 4bcae80..e8d175d 100644 (file)
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -42,19 +42,22 @@
 (define (decode-load-program pop)
   (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
          (a (pop)) (b (pop)) (c (pop)) (d (pop))
+         (e (pop)) (f (pop)) (g (pop)) (h (pop))
          (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))
          (i 0))
     (define (sub-pop) ;; ...records. ha. ha.
-      (let ((b (cond ((< i len) (pop))
-                     ((= i len) #f)
+      (let ((b (cond ((< i totlen) (pop))
+                     ((= i totlen) #f)
                      (else (error "tried to decode too many bytes")))))
         (if b (set! i (1+ i)))
         b))
     (let lp ((out '()))
-      (cond ((> i len)
+      (cond ((> i totlen)
              (error "error decoding program -- read too many bytes" out))
-            ((= i len)
-             `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len
+            ((= i totlen)
+             `(load-program ,nargs ,nrest ,nlocs ,nexts () ,len ,metalen
                             ,@(reverse! out)))
             (else
              (let ((exp (decode-bytecode sub-pop)))

diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 7c7ba15..7a56919 100644 (file)
--- a/module/language/assembly/disassemble.scm
+++ b/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 . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,metalen . ,code)
      (let ((objs  (and env (assq-ref env 'objects)))
            (meta  (and env (assq-ref env 'meta)))
            (exts  (and env (assq-ref env 'exts)))

diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 5569930..fc75930 100644 (file)
--- a/module/language/glil/compile-assembly.scm
+++ b/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 . ,code)))
+                                    ,len 0 . ,code)))
            (cond
             (toplevel?
              ;; toplevel bytecode isn't loaded by the vm, no way to do

diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index daad0b3..8064489 100644 (file)
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -77,7 +77,7 @@
                        (char->integer #\x)))
     
     ;; fixme: little-endian test.
-    (comp-test '(load-program 3 2 1 0 '() 3 (make-int8 3) (return))
-               (vector 'load-program 3 2 1 0 3 0 0 0
+    (comp-test '(load-program 3 2 1 0 '() 3 0 (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)))))