mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
speed up compile-bytecode
* module/language/assembly/compile-bytecode.scm (compile-bytecode): Rewrite to fill a bytevector directly, instead of using bytevector ports. `write-bytecode' itself is still present and almost the same as before; it's just that `write-byte' et al now inline the effect of writing a byte to a binary port. * test-suite/tests/asm-to-bytecode.test (comp-test): Refactor to use public interfaces.
This commit is contained in:
Andy Wingo
parent
81f529091b
commit
89f9dd7065
2 changed files with 141 additions and 110 deletions
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue