summaryrefslogtreecommitdiff
path: root/module/language/assembly/compile-bytecode.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-01-30 10:20:08 +0100
committerAndy Wingo <wingo@pobox.com>2009-01-30 10:20:08 +0100
commit6f78702819e355180a71de6902766cdecfa84755 (patch)
tree94223eb892173b58523e075e585987b08184e594 /module/language/assembly/compile-bytecode.scm
parentbd02af8acfcb8250ac111b9140615dd58533db30 (diff)
downloadguile-6f78702819e355180a71de6902766cdecfa84755.tar.gz
add new language between assembly and objcode: bytecode
* module/language/bytecode/Makefile.am: * module/language/bytecode/spec.scm: Add another language to the stack, bytecode. Bytecode is the u8vector form of object code.. * configure.in: * module/language/Makefile.am: * module/language/assembly/Makefile.am: * test-suite/tests/asm-to-bytecode.test: * module/language/assembly/spec.scm: * module/language/assembly/compile-bytecode.scm: Update to include the new pass.
Diffstat (limited to 'module/language/assembly/compile-bytecode.scm')
-rw-r--r--module/language/assembly/compile-bytecode.scm118
1 files changed, 118 insertions, 0 deletions
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
new file mode 100644
index 000000000..e0d0af923
--- /dev/null
+++ b/module/language/assembly/compile-bytecode.scm
@@ -0,0 +1,118 @@
+;;; Guile VM assembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language assembly compile-bytecode)
+ #:use-module (system base pmatch)
+ #:use-module (system vm instruction)
+ #:use-module (srfi srfi-4)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (compile-bytecode write-bytecode))
+
+(define *program-header-len* 8)
+
+(define (compile-bytecode assembly env . opts)
+ (pmatch assembly
+ ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
+ (letrec ((v (make-u8vector (+ *program-header-len* len)))
+ (i -1)
+ (write-byte (lambda (b)
+ ;; drop the load-program byte
+ (if (>= i 0) (u8vector-set! v i b))
+ (set! i (1+ i))))
+ (get-addr (lambda () i)))
+ (write-bytecode assembly write-byte get-addr '())
+ (if (not (= i (u8vector-length v)))
+ (error "incorrect length in assembly" i len))
+ (values v env)))
+ (else (error "bad assembly" assembly))))
+
+(define (write-bytecode asm write-byte get-addr labels)
+ (define (write-char c)
+ (write-byte (char->integer c)))
+ (define (write-string s)
+ (string-for-each write-char s))
+ (define (write-uint16-be x)
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
+ (define (write-uint16-le x)
+ (write-byte (logand x 255))
+ (write-byte (logand (ash x -8) 255)))
+ (define (write-uint32-be x)
+ (write-byte (logand (ash x -24) 255))
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
+ (define (write-uint32-le x)
+ (write-byte (logand x 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -24) 255)))
+ (define (write-loader-len len)
+ (write-byte (ash len -16))
+ (write-byte (logand (ash len -8) 255))
+ (write-byte (logand len 255)))
+ (define (write-loader str)
+ (write-loader-len (string-length str))
+ (write-string str))
+ (define (write-break label)
+ (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
+
+ (let ((inst (car asm))
+ (args (cdr asm)))
+ (let ((opcode (instruction->opcode inst))
+ (len (instruction-length inst)))
+ (write-byte opcode)
+ (pmatch asm
+ ((load-program ,nargs ,nrest ,nlocs ,nexts
+ ,labels ,length . ,code)
+ (write-byte nargs)
+ (write-byte nrest)
+ (write-byte nlocs)
+ (write-byte nexts)
+ (write-uint32-le length) ;; FIXME!
+ (letrec ((i 0)
+ (write (lambda (x) (set! i (1+ i)) (write-byte x)))
+ (get-addr (lambda () i)))
+ (for-each (lambda (asm)
+ (write-bytecode asm write get-addr labels))
+ code)))
+ ((load-integer ,str) (write-loader str))
+ ((load-number ,str) (write-loader str))
+ ((load-string ,str) (write-loader str))
+ ((load-symbol ,str) (write-loader str))
+ ((load-keyword ,str) (write-loader str))
+ ((define ,str) (write-loader str))
+ ((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))
+ ((mv-call ,n ,l) (write-byte n) (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))))))))