mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

speed up compile-bytecode

Browse source 
* 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 2011-05-05 11:22:42 +02:00
parent 81f529091b
commit 89f9dd7065
2 changed files with 141 additions and 110 deletions
Download patch file Download diff file Expand all files Collapse all files

139
module/language/assembly/compile-bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM assembler ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -22,60 +22,77 @@
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (language assembly) #:use-module (language assembly)
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((srfi srfi-26) #:select (cut))
#:export (compile-bytecode)) #:export (compile-bytecode))
;; Gross.
(define (port-position port)
(seek port 0 SEEK_CUR))
(define (compile-bytecode assembly env . opts) (define (compile-bytecode assembly env . opts)
(pmatch assembly (define-syntax define-inline1
((load-program . _) (syntax-rules ()
(call-with-values open-bytevector-output-port ((_ (proc arg) body body* ...)
(lambda (port get-bytevector) (define-syntax proc
;; Don't emit the `load-program' byte. (syntax-rules ()
(write-bytecode assembly port '() 0 #f) ((_ (arg-expr (... ...)))
(values (get-bytevector) env env)))) (let ((x (arg-expr (... ...))))
(else (error "bad assembly" assembly)))) (proc x)))
((_ arg)
(begin body body* ...)))))))
(define (write-bytecode asm port labels address emit-opcode?) (define (fill-bytecode bv)
;; Write ASM's bytecode to PORT, a (binary) output port. If EMIT-OPCODE? is (let ((pos 0))
;; false, don't emit bytecode for the first opcode encountered. Assume code (define-inline1 (write-byte b)
;; starts at ADDRESS (an integer). LABELS is assumed to be an alist mapping (bytevector-u8-set! bv pos b)
;; labels to addresses. (set! pos (1+ pos)))
(define u32-bv (make-bytevector 4)) (define u32-bv (make-bytevector 4))
(define write-byte (cut put-u8 port <>)) (define-inline1 (write-int24-be x)
(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)) (bytevector-s32-set! u32-bv 0 x (endianness big))
(put-bytevector port u32-bv 1 3)) (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
(define (write-uint32-be x) (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
(bytevector-u32-set! u32-bv 0 x (endianness big)) (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
(put-bytevector port u32-bv)) (set! pos (+ pos 3)))
(define (write-uint32 x) (define-inline1 (write-uint32-be x)
(bytevector-u32-native-set! u32-bv 0 x) (bytevector-u32-set! bv pos x (endianness big))
(put-bytevector port u32-bv)) (set! pos (+ pos 4)))
(define (write-wide-string s) (define-inline1 (write-uint32 x)
(write-loader-len (* 4 (string-length s))) (bytevector-u32-native-set! bv pos x)
(put-bytevector port (string->utf32 s (native-endianness)))) (set! pos (+ pos 4)))
(define (write-loader-len len) (define-inline1 (write-loader-len len)
(write-byte (ash len -16)) (bytevector-u8-set! bv pos (ash len -16))
(write-byte (logand (ash len -8) 255)) (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
(write-byte (logand len 255))) (bytevector-u8-set! bv (+ pos 2) (logand len 255))
(define (write-bytevector bv) (set! pos (+ pos 3)))
(write-loader-len (bytevector-length bv)) (define-inline1 (write-latin1-string s)
(put-bytevector port bv)) (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 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) (define (write-break label)
(let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) (let ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
(cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
@ -93,9 +110,9 @@
(write-uint32 length) (write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0)) (write-uint32 (if meta (1- (byte-length meta)) 0))
(fold (lambda (asm address) (fold (lambda (asm address)
(let ((start (port-position port))) (let ((start pos))
(write-bytecode asm port labels address #t) (write-bytecode asm labels address #t)
(+ address (- (port-position port) start)))) (+ address (- pos start))))
0 0
code) code)
(if meta (if meta
@ -103,7 +120,7 @@
;; META's bytecode meets the alignment requirements of ;; META's bytecode meets the alignment requirements of
;; `scm_objcode', thanks to the alignment computed in `(language ;; `scm_objcode', thanks to the alignment computed in `(language
;; assembly)'. ;; assembly)'.
(write-bytecode meta port '() 0 #f))) (write-bytecode meta '() 0 #f)))
((make-char32 ,x) (write-uint32-be x)) ((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-latin1-string str)) ((load-number ,str) (write-latin1-string str))
((load-string ,str) (write-latin1-string str)) ((load-string ,str) (write-latin1-string str))
@ -124,9 +141,25 @@
((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l)) ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
(else (else
(cond (cond
((< (instruction-length inst) 0) ((< len 0)
(error "unhanded variable-length instruction" asm)) (error "unhanded variable-length instruction" asm))
((not (= (length args) len)) ((not (= (length args) len))
(error "bad number of args to instruction" asm len)) (error "bad number of args to instruction" asm len))
(else (else
(for-each write-byte args)))))))) (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))))

14
test-suite/tests/asm-to-bytecode.test
View file

@ -19,11 +19,9 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port)) #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib) #:use-module (test-suite lib)
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module (language assembly)
#:use-module (language assembly compile-bytecode)) #:use-module (language assembly compile-bytecode))
(define write-bytecode
(@@ (language assembly compile-bytecode) write-bytecode))
(define (->u8-list sym val) (define (->u8-list sym val)
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
(uint32 4 ,bytevector-u32-native-set!)) (uint32 4 ,bytevector-u32-native-set!))
@ -54,11 +52,11 @@
(run-test `(length ,x) #t (run-test `(length ,x) #t
(lambda () (lambda ()
(call-with-values open-bytevector-output-port (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
(lambda (port get-bytevector) (bv (compile-bytecode wrapped '())))
(write-bytecode x port '() 0 #t) (set! v (make-bytevector (- (bytevector-length bv) 8)))
(set! v (get-bytevector)) (bytevector-copy! bv 8 v 0 (bytevector-length v))
(= (bytevector-length v) len))))) (= (bytevector-length v) len))))
(run-test `(compile-equal? ,x ,y) #t (run-test `(compile-equal? ,x ,y) #t
(lambda () (lambda ()
(equal? v y))))) (equal? v y)))))