diff options
Diffstat (limited to 'module/language/assembly/compile-bytecode.scm')
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 125 |
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) |