nlocs is now 16 bits wide

* libguile/objcodes.h (struct scm_objcode): Remove the "unused" field --
  the old "nexts" -- and expand nlocs to 16 bits.

* module/language/assembly/compile-bytecode.scm (write-bytecode): Write
  the nlocs as a uint16.

* module/language/assembly/decompile-bytecode.scm (decode-load-program):
  Decompile 16-bit nlocs. It seems this decompilation is little-endian
  :-/

* test-suite/tests/asm-to-bytecode.test: Fix up to understand nlocs as a
  little-endian value. The test does the right thing regarding
  endianness.

libguile/objcodes.h

@@ -25,8 +25,7 @@
 struct scm_objcode {
   scm_t_uint8 nargs;
   scm_t_uint8 nrest;
-  scm_t_uint8 nlocs;
+  scm_t_uint16 nlocs;
-  scm_t_uint8 unused;
   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 */

module/language/assembly/compile-bytecode.scm

@@ -81,6 +81,10 @@
   
   (let ((inst (car asm))
         (args (cdr asm))
+        (write-uint16 (case byte-order
+                        ((1234) write-uint16-le)
+                        ((4321) write-uint16-be)
+                        (else (error "unknown endianness" byte-order))))
         (write-uint32 (case byte-order
                         ((1234) write-uint32-le)
                         ((4321) write-uint32-be)
@@ -92,8 +96,7 @@
         ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
          (write-byte nargs)
          (write-byte nrest)
-         (write-byte nlocs)
+         (write-uint16 nlocs)
-         (write-byte 0) ;; what used to be nexts
          (write-uint32 length)
          (write-uint32 (if meta (1- (byte-length meta)) 0))
          (letrec ((i 0)

module/language/assembly/decompile-bytecode.scm

@@ -48,8 +48,10 @@
         x
         (- x (ash 1 16)))))
 
+;; FIXME: this is a little-endian disassembly!!!
 (define (decode-load-program pop)
-  (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop))
+  (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
+         (nlocs (+ nlocs0 (ash nlocs1 8)))
          (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)))

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

@@ -20,16 +20,28 @@
   #:use-module (system vm instruction)
   #:use-module (language assembly compile-bytecode))
 
+(define (->u8-list sym val)
+  (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
+                           (uint32 4 ,bytevector-u32-native-set!))
+                         sym)))
+    (or entry (error "unknown sym" sym))
+    (let ((bv (make-bytevector (car entry))))
+      ((cadr entry) bv 0 val)
+      (bytevector->u8-list bv))))
+
 (define (munge-bytecode v)
-  (let ((newv (make-u8vector (vector-length v))))
+  (let lp ((i 0) (out '()))
-    (let lp ((i 0))
+    (if (= i (vector-length v))
-      (if (= i (vector-length v))
+        (list->u8vector (reverse out))
-          newv
+        (let ((x (vector-ref v i)))
-          (let ((x (vector-ref v i)))
+          (cond
-            (u8vector-set! newv i (if (symbol? x)
+           ((symbol? x)
-                                      (instruction->opcode x)
+            (lp (1+ i) (cons (instruction->opcode x) out)))
-                                      x))
+           ((integer? x)
-            (lp (1+ i)))))))
+            (lp (1+ i) (cons x out)))
+           ((pair? x)
+            (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
+           (else (error "bad test bytecode" x)))))))
 
 (define (comp-test x y)
   (let* ((y (munge-bytecode y))
@@ -46,13 +58,6 @@
               (lambda ()
                 (equal? v y)))))
 
-(define (u32->u8-list x)
-  ;; Return a 4 uint8 list corresponding to the host's native representation
-  ;; of X, a uint32.
-  (let ((bv (make-bytevector 4)))
-    (bytevector-u32-native-set! bv 0 x)
-    (bytevector->u8-list bv)))
-
 
 (with-test-prefix "compiler"
   (with-test-prefix "asm-to-bytecode"
@@ -86,28 +91,26 @@
                        (char->integer #\x)))
 
     (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
-               (list->vector
+               #(load-program
-                `(load-program
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  3 2 1 0            ;; nargs, nrest, nlocs, unused
+                 (uint32 3)     ;; len
-                  ,@(u32->u8-list 3) ;; len
+                 (uint32 0)     ;; metalen
-                  ,@(u32->u8-list 0) ;; metalen
+                 make-int8 3
-                  make-int8 3
+                 return))
-                  return)))
 
     (comp-test '(load-program 3 2 1 () 3
                               (load-program 3 2 1 () 3
                                             #f
                                             (make-int8 3) (return))
                               (make-int8 3) (return))
-               (list->vector
+               #(load-program
-                `(load-program
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  3 2 1 0                   ;; nargs, nrest, nlocs, unused
+                 (uint32 3)     ;; len
-                  ,@(u32->u8-list 3)        ;; len
+                 (uint32 15)    ;; metalen
-                  ,@(u32->u8-list (+ 3 12)) ;; metalen
+                 make-int8 3
-                  make-int8 3
+                 return
-                  return
+                 3 2 (uint16 1) ;; nargs, nrest, nlocs
-                  3 2 1 0                   ;; nargs, nrest, nlocs, unused
+                 (uint32 3)     ;; len
-                  ,@(u32->u8-list 3)        ;; len
+                 (uint32 0)     ;; metalen
-                  ,@(u32->u8-list 0)        ;; metalen
+                 make-int8 3
-                  make-int8 3
+                 return))))
-                  return)))))