summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/assembly/compile-bytecode.scm49
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?