diff options
Diffstat (limited to 'module/language/assembly/compile-bytecode.scm')
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 49 |
1 files changed, 13 insertions, 36 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index fe5fc2fc1..98fb27fed 100644 --- a/module/language/assembly/compile-bytecode.scm +++ b/module/language/assembly/compile-bytecode.scm @@ -27,7 +27,6 @@ #:use-module (rnrs io ports) #:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-26) #:select (cut)) - #:use-module ((system vm objcode) #:select (byte-order)) #:export (compile-bytecode write-bytecode)) (define (compile-bytecode assembly env . opts) @@ -45,43 +44,26 @@ ;; false, don't emit bytecode for the first opcode encountered. Assume code ;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping ;; labels to addresses. + (define u32-bv (make-bytevector 4)) (define write-byte (cut put-u8 port <>)) (define get-addr (let ((start (port-position port))) (lambda () (+ address (- (port-position port) start))))) - (define (write-char c) - (write-byte (char->integer c))) (define (write-string s) - (string-for-each write-char s)) - (define (write-uint16-be x) - (write-byte (logand (ash x -8) 255)) - (write-byte (logand x 255))) - (define (write-uint16-le x) - (write-byte (logand x 255)) - (write-byte (logand (ash x -8) 255))) - (define (write-uint24-be x) - (write-byte (logand (ash x -16) 255)) - (write-byte (logand (ash x -8) 255)) - (write-byte (logand x 255))) + (put-bytevector port (string->utf8 s))) + (define (write-int24-be x) + (bytevector-s32-set! u32-bv 0 x (endianness big)) + (put-bytevector port u32-bv 1 3)) (define (write-uint32-be x) - (write-byte (logand (ash x -24) 255)) - (write-byte (logand (ash x -16) 255)) - (write-byte (logand (ash x -8) 255)) - (write-byte (logand x 255))) - (define (write-uint32-le x) - (write-byte (logand x 255)) - (write-byte (logand (ash x -8) 255)) - (write-byte (logand (ash x -16) 255)) - (write-byte (logand (ash x -24) 255))) + (bytevector-u32-set! u32-bv 0 x (endianness big)) + (put-bytevector port u32-bv)) (define (write-uint32 x) - (case byte-order - ((1234) (write-uint32-le x)) - ((4321) (write-uint32-be x)) - (else (error "unknown endianness" byte-order)))) + (bytevector-u32-native-set! u32-bv 0 x) + (put-bytevector port u32-bv)) (define (write-wide-string s) (write-loader-len (* 4 (string-length s))) - (string-for-each (lambda (c) (write-uint32 (char->integer c))) s)) + (put-bytevector port (string->utf32 s (native-endianness)))) (define (write-loader-len len) (write-byte (ash len -16)) (write-byte (logand (ash len -8) 255)) @@ -91,20 +73,15 @@ (write-string str)) (define (write-bytevector bv) (write-loader-len (bytevector-length bv)) - ;; Ew! - (for-each write-byte (bytevector->u8-list bv))) + (put-bytevector port bv)) (define (write-break label) (let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) ((< offset (- (ash 1 23))) (error "jump too far backwards" offset)) - (else (write-uint24-be offset))))) + (else (write-int24-be offset))))) (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))))) + (args (cdr asm))) (let ((opcode (instruction->opcode inst)) (len (instruction-length inst))) (if emit-opcode? |