diff options
author | Andy Wingo <wingo@pobox.com> | 2009-01-30 10:20:08 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-01-30 10:20:08 +0100 |
commit | 6f78702819e355180a71de6902766cdecfa84755 (patch) | |
tree | 94223eb892173b58523e075e585987b08184e594 /module/language/assembly/compile-bytecode.scm | |
parent | bd02af8acfcb8250ac111b9140615dd58533db30 (diff) | |
download | guile-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.scm | 118 |
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)))))))) |