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.

2 files changed, 141 insertions, 110 deletions

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)))))