diff options
-rw-r--r-- | libguile/objcodes.h | 3 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 7 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 4 | ||||
-rw-r--r-- | test-suite/tests/asm-to-bytecode.test | 73 |
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)))) |