Commit | Line | Data |
---|---|---|
53e28ed9 AW |
1 | ;;; Guile VM assembler |
2 | ||
b912a1cd | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
53e28ed9 | 4 | |
53befeb7 NJ |
5 | ;;;; This library is free software; you can redistribute it and/or |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
53e28ed9 AW |
18 | |
19 | ;;; Code: | |
20 | ||
6f787028 | 21 | (define-module (language assembly compile-bytecode) |
53e28ed9 | 22 | #:use-module (system base pmatch) |
4b318482 | 23 | #:use-module (language assembly) |
53e28ed9 | 24 | #:use-module (system vm instruction) |
53e28ed9 | 25 | #:use-module (srfi srfi-4) |
782a82ee | 26 | #:use-module (rnrs bytevector) |
53e28ed9 | 27 | #:use-module ((srfi srfi-1) #:select (fold)) |
3928db00 | 28 | #:use-module ((system vm objcode) #:select (byte-order)) |
6f787028 | 29 | #:export (compile-bytecode write-bytecode)) |
53e28ed9 | 30 | |
6f787028 | 31 | (define (compile-bytecode assembly env . opts) |
53e28ed9 | 32 | (pmatch assembly |
4b318482 AW |
33 | ((load-program . _) |
34 | ;; the 1- and -1 are so that we drop the load-program byte | |
35 | (letrec ((v (make-u8vector (1- (byte-length assembly)))) | |
53e28ed9 AW |
36 | (i -1) |
37 | (write-byte (lambda (b) | |
53e28ed9 AW |
38 | (if (>= i 0) (u8vector-set! v i b)) |
39 | (set! i (1+ i)))) | |
40 | (get-addr (lambda () i))) | |
6f787028 | 41 | (write-bytecode assembly write-byte get-addr '()) |
4b318482 | 42 | (if (= i (u8vector-length v)) |
b41b92c9 | 43 | (values v env env) |
4b318482 | 44 | (error "incorrect length in assembly" i (u8vector-length v))))) |
53e28ed9 AW |
45 | (else (error "bad assembly" assembly)))) |
46 | ||
6f787028 | 47 | (define (write-bytecode asm write-byte get-addr labels) |
53e28ed9 AW |
48 | (define (write-char c) |
49 | (write-byte (char->integer c))) | |
50 | (define (write-string s) | |
51 | (string-for-each write-char s)) | |
52 | (define (write-uint16-be x) | |
53 | (write-byte (logand (ash x -8) 255)) | |
54 | (write-byte (logand x 255))) | |
55 | (define (write-uint16-le x) | |
56 | (write-byte (logand x 255)) | |
57 | (write-byte (logand (ash x -8) 255))) | |
58 | (define (write-uint32-be x) | |
59 | (write-byte (logand (ash x -24) 255)) | |
60 | (write-byte (logand (ash x -16) 255)) | |
61 | (write-byte (logand (ash x -8) 255)) | |
62 | (write-byte (logand x 255))) | |
63 | (define (write-uint32-le x) | |
64 | (write-byte (logand x 255)) | |
65 | (write-byte (logand (ash x -8) 255)) | |
66 | (write-byte (logand (ash x -16) 255)) | |
67 | (write-byte (logand (ash x -24) 255))) | |
68 | (define (write-loader-len len) | |
69 | (write-byte (ash len -16)) | |
70 | (write-byte (logand (ash len -8) 255)) | |
71 | (write-byte (logand len 255))) | |
72 | (define (write-loader str) | |
73 | (write-loader-len (string-length str)) | |
74 | (write-string str)) | |
782a82ee AW |
75 | (define (write-bytevector bv) |
76 | (write-loader-len (bytevector-length bv)) | |
77 | ;; Ew! | |
78 | (for-each write-byte (bytevector->u8-list bv))) | |
53e28ed9 AW |
79 | (define (write-break label) |
80 | (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2)))) | |
81 | ||
82 | (let ((inst (car asm)) | |
3928db00 | 83 | (args (cdr asm)) |
ccf77d95 AW |
84 | (write-uint16 (case byte-order |
85 | ((1234) write-uint16-le) | |
86 | ((4321) write-uint16-be) | |
87 | (else (error "unknown endianness" byte-order)))) | |
3928db00 AW |
88 | (write-uint32 (case byte-order |
89 | ((1234) write-uint32-le) | |
90 | ((4321) write-uint32-be) | |
91 | (else (error "unknown endianness" byte-order))))) | |
53e28ed9 AW |
92 | (let ((opcode (instruction->opcode inst)) |
93 | (len (instruction-length inst))) | |
94 | (write-byte opcode) | |
95 | (pmatch asm | |
476e3572 | 96 | ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code) |
53e28ed9 AW |
97 | (write-byte nargs) |
98 | (write-byte nrest) | |
ccf77d95 | 99 | (write-uint16 nlocs) |
3928db00 AW |
100 | (write-uint32 length) |
101 | (write-uint32 (if meta (1- (byte-length meta)) 0)) | |
53e28ed9 AW |
102 | (letrec ((i 0) |
103 | (write (lambda (x) (set! i (1+ i)) (write-byte x))) | |
104 | (get-addr (lambda () i))) | |
105 | (for-each (lambda (asm) | |
6f787028 | 106 | (write-bytecode asm write get-addr labels)) |
1f1ec13b AW |
107 | code)) |
108 | (if meta | |
109 | ;; don't write the load-program byte for metadata | |
110 | (letrec ((i -1) | |
111 | (write (lambda (x) | |
112 | (set! i (1+ i)) | |
113 | (if (> i 0) (write-byte x)))) | |
114 | (get-addr (lambda () i))) | |
ec99fe8e LC |
115 | ;; FIXME: We should add padding here so that META's bytecode |
116 | ;; meets the alignment requirements of `scm_objcode'. See | |
117 | ;; `scm_c_make_objcode_slice ()'. | |
1f1ec13b | 118 | (write-bytecode meta write get-addr '())))) |
b912a1cd | 119 | ((load-unsigned-integer ,str) (write-loader str)) |
53e28ed9 AW |
120 | ((load-integer ,str) (write-loader str)) |
121 | ((load-number ,str) (write-loader str)) | |
122 | ((load-string ,str) (write-loader str)) | |
123 | ((load-symbol ,str) (write-loader str)) | |
124 | ((load-keyword ,str) (write-loader str)) | |
782a82ee | 125 | ((load-array ,bv) (write-bytevector bv)) |
53e28ed9 AW |
126 | ((define ,str) (write-loader str)) |
127 | ((br ,l) (write-break l)) | |
128 | ((br-if ,l) (write-break l)) | |
129 | ((br-if-not ,l) (write-break l)) | |
130 | ((br-if-eq ,l) (write-break l)) | |
131 | ((br-if-not-eq ,l) (write-break l)) | |
132 | ((br-if-null ,l) (write-break l)) | |
133 | ((br-if-not-null ,l) (write-break l)) | |
134 | ((mv-call ,n ,l) (write-byte n) (write-break l)) | |
135 | (else | |
136 | (cond | |
137 | ((< (instruction-length inst) 0) | |
138 | (error "unhanded variable-length instruction" asm)) | |
139 | ((not (= (length args) len)) | |
140 | (error "bad number of args to instruction" asm len)) | |
141 | (else | |
142 | (for-each write-byte args)))))))) |