diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm index ae6476891..c31582991 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, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011 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 @@ -22,111 +22,144 @@ #:use-module (system base pmatch) #:use-module (language assembly) #:use-module (system vm instruction) - #:use-module (srfi srfi-4) #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module ((srfi srfi-26) #:select (cut)) #:export (compile-bytecode)) -;; Gross. -(define (port-position port) - (seek port 0 SEEK_CUR)) - (define (compile-bytecode assembly env . opts) - (pmatch assembly - ((load-program . _) - (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-syntax define-inline1 + (syntax-rules () + ((_ (proc arg) body body* ...) + (define-syntax proc + (syntax-rules () + ((_ (arg-expr (... ...))) + (let ((x (arg-expr (... ...)))) + (proc x))) + ((_ arg) + (begin body body* ...))))))) + + (define (fill-bytecode bv) + (let ((pos 0)) + (define-inline1 (write-byte b) + (bytevector-u8-set! bv pos b) + (set! pos (1+ pos))) + (define u32-bv (make-bytevector 4)) + (define-inline1 (write-int24-be x) + (bytevector-s32-set! u32-bv 0 x (endianness big)) + (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1)) + (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2)) + (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3)) + (set! pos (+ pos 3))) + (define-inline1 (write-uint32-be x) + (bytevector-u32-set! bv pos x (endianness big)) + (set! pos (+ pos 4))) + (define-inline1 (write-uint32 x) + (bytevector-u32-native-set! bv pos x) + (set! pos (+ pos 4))) + (define-inline1 (write-loader-len len) + (bytevector-u8-set! bv pos (ash len -16)) + (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255)) + (bytevector-u8-set! bv (+ pos 2) (logand len 255)) + (set! pos (+ pos 3))) + (define-inline1 (write-latin1-string s) + (let ((len (string-length s))) + (write-loader-len len) + (let lp ((i 0)) + (if (< i len) + (begin + (bytevector-u8-set! bv (+ pos i) + (char->integer (string-ref s i))) + (lp (1+ i))))) + (set! pos (+ pos len)))) + (define-inline1 (write-bytevector bv*) + (let ((len (bytevector-length bv*))) + (write-loader-len len) + (bytevector-copy! bv* 0 bv pos len) + (set! pos (+ pos len)))) + (define-inline1 (write-wide-string s) + (write-bytevector (string->utf32 s (native-endianness)))) + (define-inline1 (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-int24-be offset))))) -(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) - (bytevector-u32-set! u32-bv 0 x (endianness big)) - (put-bytevector port u32-bv)) - (define (write-uint32 x) - (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))) - (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-bytevector bv) - (write-loader-len (bytevector-length 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-int24-be offset))))) + (define (write-bytecode asm labels address emit-opcode?) + ;; Write ASM's bytecode to BV. 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 get-addr + (let ((start pos)) + (lambda () + (+ address (- pos start))))) + (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-int24-be offset))))) - (let ((inst (car asm)) - (args (cdr asm))) - (let ((opcode (instruction->opcode inst)) - (len (instruction-length inst))) - (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)) - (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 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-latin1-string str)) - ((load-string ,str) (write-latin1-string str)) - ((load-wide-string ,str) (write-wide-string 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)) - ((br-if-not ,l) (write-break l)) - ((br-if-eq ,l) (write-break l)) - ((br-if-not-eq ,l) (write-break l)) - ((br-if-null ,l) (write-break l)) - ((br-if-not-null ,l) (write-break l)) - ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) - ((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) - (error "unhanded variable-length instruction" asm)) - ((not (= (length args) len)) - (error "bad number of args to instruction" asm len)) - (else - (for-each write-byte args)))))))) + (let ((inst (car asm)) + (args (cdr asm))) + (let ((opcode (instruction->opcode inst)) + (len (instruction-length inst))) + (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)) + (fold (lambda (asm address) + (let ((start pos)) + (write-bytecode asm labels address #t) + (+ address (- pos start)))) + 0 + code) + (if meta + ;; 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 '() 0 #f))) + ((make-char32 ,x) (write-uint32-be x)) + ((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-latin1-string str)) + ((load-array ,bv) (write-bytevector bv)) + ((br ,l) (write-break l)) + ((br-if ,l) (write-break l)) + ((br-if-not ,l) (write-break l)) + ((br-if-eq ,l) (write-break l)) + ((br-if-not-eq ,l) (write-break l)) + ((br-if-null ,l) (write-break l)) + ((br-if-not-null ,l) (write-break l)) + ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) + ((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 + ((< len 0) + (error "unhanded variable-length instruction" asm)) + ((not (= (length args) len)) + (error "bad number of args to instruction" asm len)) + (else + (for-each (lambda (x) (write-byte x)) args)))))))) + + ;; Don't emit the `load-program' byte. + (write-bytecode assembly '() 0 #f) + (if (= pos (bytevector-length bv)) + (values bv env env) + (error "failed to fill bytevector" bv pos + (bytevector-length bv))))) + + (pmatch assembly + ((load-program ,labels ,length ,meta . ,code) + (fill-bytecode (make-bytevector (+ 4 4 length + (if meta + (1- (byte-length meta)) + 0))))) + + (else (error "bad assembly" assembly)))) diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test index 0d8fecb5a..049e4b2fd 100644 --- a/test-suite/tests/asm-to-bytecode.test +++ b/test-suite/tests/asm-to-bytecode.test @@ -19,11 +19,9 @@ #:use-module ((rnrs io ports) #:select (open-bytevector-output-port)) #:use-module (test-suite lib) #:use-module (system vm instruction) + #:use-module (language assembly) #:use-module (language assembly compile-bytecode)) -(define write-bytecode - (@@ (language assembly compile-bytecode) write-bytecode)) - (define (->u8-list sym val) (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) (uint32 4 ,bytevector-u32-native-set!)) @@ -54,11 +52,11 @@ (run-test `(length ,x) #t (lambda () - (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))))) + (let* ((wrapped `(load-program () ,(byte-length x) #f ,x)) + (bv (compile-bytecode wrapped '()))) + (set! v (make-bytevector (- (bytevector-length bv) 8))) + (bytevector-copy! bv 8 v 0 (bytevector-length v)) + (= (bytevector-length v) len)))) (run-test `(compile-equal? ,x ,y) #t (lambda () (equal? v y)))))