summaryrefslogtreecommitdiff
path: root/module/language/assembly/compile-bytecode.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/assembly/compile-bytecode.scm')
-rw-r--r--module/language/assembly/compile-bytecode.scm125
1 files changed, 51 insertions, 74 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index e6fc5bc2a..8a4c5cd41 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Guile VM assembler
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -24,111 +24,87 @@
#: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 ((system vm objcode) #:select (byte-order))
- #:export (compile-bytecode write-bytecode))
+ #:use-module ((srfi srfi-26) #:select (cut))
+ #:export (compile-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-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)))
+(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 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-latin1-string s)
+ (write-loader-len (string-length s))
+ (string-for-each (lambda (c) (write-byte (char->integer c))) 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))
(write-byte (logand len 255)))
- (define (write-loader str)
- (write-loader-len (string-length str))
- (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)))
- (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))
+ ((load-number ,str) (write-latin1-string str))
+ ((load-string ,str) (write-latin1-string str))
((load-wide-string ,str) (write-wide-string str))
- ((load-symbol ,str) (write-loader str))
+ ((load-symbol ,str) (write-latin1-string str))
((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
@@ -141,6 +117,7 @@
((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
+ ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else
(cond
((< (instruction-length inst) 0)