-;;; Guile VM assembler
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-(define-module (language assembly compile-bytecode)
- #: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 (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)))))
-
- (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))))))))
+;;; Guile VM assembler
+
+;; 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language assembly compile-bytecode)
+ #:use-module (system base pmatch)
+ #:use-module (language assembly)
+ #:use-module (system vm instruction)
+ #:use-module (rnrs bytevectors)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (compile-bytecode))
+
+(define (compile-bytecode assembly env . opts)
+ (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 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 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))))
HCoop / bpt / guile.git / blobdiff