summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-02-05 11:11:56 +0100
committerLudovic Courtès <ludo@gnu.org>2010-02-10 00:40:01 +0100
commitbde92e6b3bbd15c7abaf29bc0557041b88df8d74 (patch)
tree3e40524196deb02ba38460cc32be04bc1cb4a710
parent0c368d2b2811fb856c9551e7ad217f8e5636024f (diff)
downloadguile-bde92e6b3bbd15c7abaf29bc0557041b88df8d74.tar.gz
Change `write-bytecode' to accept a bytevector.
* module/language/assembly/compile-bytecode.scm (write-bytecode): Replace the WRITE-BYTE and GET-ADDR parameters with PORT. New ADDRESS and EMIT-OPCODE? parameters. Callers updated. [write-byte, get-addr]: New procedures. Adjust to write to PORT. (compile-bytecode): Update accordingly. * test-suite/tests/asm-to-bytecode.test (munge-bytecode): Return a bytevector instead of a u8vector. (comp-test): Deal with bytevectors.
-rw-r--r--module/language/assembly/compile-bytecode.scm59
-rw-r--r--test-suite/tests/asm-to-bytecode.test20
2 files changed, 41 insertions, 38 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index f04514804..fe5fc2fc1 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -24,27 +24,32 @@
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
+ #: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)
(pmatch assembly
((load-program . _)
- ;; the 1- and -1 are so that we drop the load-program byte
- (letrec ((v (make-u8vector (1- (byte-length assembly))))
- (i -1)
- (write-byte (lambda (b)
- (if (>= i 0) (u8vector-set! v i b))
- (set! i (1+ i))))
- (get-addr (lambda () i)))
- (write-bytecode assembly write-byte get-addr '())
- (if (= i (u8vector-length v))
- (values v env env)
- (error "incorrect length in assembly" i (u8vector-length v)))))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ ;; Don't emit the `load-program' byte.
+ (write-bytecode assembly port '() 0 #f)
+ (values (get-bytevector) env env))))
(else (error "bad assembly" assembly))))
-(define (write-bytecode asm write-byte get-addr labels)
+(define (write-bytecode asm port labels address emit-opcode?)
+ ;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is
+ ;; 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 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)
@@ -102,28 +107,24 @@
(else (error "unknown endianness" byte-order)))))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
- (write-byte opcode)
+ (if emit-opcode?
+ (write-byte opcode))
(pmatch asm
((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (letrec ((i 0)
- (write (lambda (x) (set! i (1+ i)) (write-byte x)))
- (get-addr (lambda () i)))
- (for-each (lambda (asm)
- (write-bytecode asm write get-addr labels))
- code))
+ (fold (lambda (asm address)
+ (let ((start (port-position port)))
+ (write-bytecode asm port labels address #t)
+ (+ address (- (port-position port) start))))
+ 0
+ code)
(if meta
- ;; don't write the load-program byte for metadata
- (letrec ((i -1)
- (write (lambda (x)
- (set! i (1+ i))
- (if (> i 0) (write-byte x))))
- (get-addr (lambda () i)))
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in
- ;; `(language assembly)'.
- (write-bytecode meta write get-addr '()))))
+ ;; Don't emit the `load-program' byte for metadata. Note that
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in `(language
+ ;; assembly)'.
+ (write-bytecode meta port '() 0 #f)))
((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 304a84da9..6e89d860f 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -16,6 +16,7 @@
(define-module (test-suite tests asm-to-bytecode)
#:use-module (rnrs bytevector)
+ #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
#:use-module (system vm instruction)
#:use-module (language assembly compile-bytecode))
@@ -32,7 +33,7 @@
(define (munge-bytecode v)
(let lp ((i 0) (out '()))
(if (= i (vector-length v))
- (list->u8vector (reverse out))
+ (u8-list->bytevector (reverse out))
(let ((x (vector-ref v i)))
(cond
((symbol? x)
@@ -44,16 +45,17 @@
(else (error "bad test bytecode" x)))))))
(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (u8vector-length y))
- (v (make-u8vector len))
- (i 0))
- (define (write-byte b) (u8vector-set! v i b) (set! i (1+ i)))
- (define (get-addr) i)
+ (let* ((y (munge-bytecode y))
+ (len (bytevector-length y))
+ (v #f))
+
(run-test `(length ,x) #t
(lambda ()
- (write-bytecode x write-byte get-addr '())
- (= i len)))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ (write-bytecode x port '() 0 #t)
+ (set! v (get-bytevector))
+ (= (bytevector-length v) len)))))
(run-test `(compile-equal? ,x ,y) #t
(lambda ()
(equal? v y)))))