summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/objcodes.h3
-rw-r--r--module/language/assembly/compile-bytecode.scm7
-rw-r--r--module/language/assembly/decompile-bytecode.scm4
-rw-r--r--test-suite/tests/asm-to-bytecode.test73
4 files changed, 47 insertions, 40 deletions
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 6727e23e8..d50f6dc94 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -25,8 +25,7 @@
struct scm_objcode {
scm_t_uint8 nargs;
scm_t_uint8 nrest;
- scm_t_uint8 nlocs;
- scm_t_uint8 unused;
+ scm_t_uint16 nlocs;
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 */
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 0a1489845..d17e00f2f 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/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-byte 0) ;; what used to be nexts
+ (write-uint16 nlocs)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(letrec ((i 0)
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index 56f58f750..231205d08 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/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)))
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index d819a3b1b..fb598a64b 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/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))
- (if (= i (vector-length v))
- newv
- (let ((x (vector-ref v i)))
- (u8vector-set! newv i (if (symbol? x)
- (instruction->opcode x)
- x))
- (lp (1+ i)))))))
+ (let lp ((i 0) (out '()))
+ (if (= i (vector-length v))
+ (list->u8vector (reverse out))
+ (let ((x (vector-ref v i)))
+ (cond
+ ((symbol? x)
+ (lp (1+ i) (cons (instruction->opcode x) out)))
+ ((integer? x)
+ (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
- 3 2 1 0 ;; nargs, nrest, nlocs, unused
- ,@(u32->u8-list 3) ;; len
- ,@(u32->u8-list 0) ;; metalen
- make-int8 3
- return)))
+ #(load-program
+ 3 2 (uint16 1) ;; nargs, nrest, nlocs
+ (uint32 3) ;; len
+ (uint32 0) ;; metalen
+ make-int8 3
+ 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
- 3 2 1 0 ;; nargs, nrest, nlocs, unused
- ,@(u32->u8-list 3) ;; len
- ,@(u32->u8-list (+ 3 12)) ;; metalen
- make-int8 3
- return
- 3 2 1 0 ;; nargs, nrest, nlocs, unused
- ,@(u32->u8-list 3) ;; len
- ,@(u32->u8-list 0) ;; metalen
- make-int8 3
- return)))))
+ #(load-program
+ 3 2 (uint16 1) ;; nargs, nrest, nlocs
+ (uint32 3) ;; len
+ (uint32 15) ;; metalen
+ make-int8 3
+ return
+ 3 2 (uint16 1) ;; nargs, nrest, nlocs
+ (uint32 3) ;; len
+ (uint32 0) ;; metalen
+ make-int8 3
+ return))))