Commit | Line | Data |
---|---|---|
53e28ed9 AW |
1 | ;;; Guile VM assembler |
2 | ||
581f410f | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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) |
34ed9dfd | 23 | #:use-module (system base target) |
4b318482 | 24 | #:use-module (language assembly) |
53e28ed9 | 25 | #:use-module (system vm instruction) |
07d22c02 | 26 | #:use-module (rnrs bytevectors) |
53e28ed9 | 27 | #:use-module ((srfi srfi-1) #:select (fold)) |
5af3378a | 28 | #:export (compile-bytecode)) |
53e28ed9 | 29 | |
6f787028 | 30 | (define (compile-bytecode assembly env . opts) |
0c65f52c AW |
31 | (define-syntax-rule (define-inline1 (proc arg) body body* ...) |
32 | (define-syntax proc | |
33 | (syntax-rules () | |
34 | ((_ (arg-expr (... ...))) | |
35 | (let ((x (arg-expr (... ...)))) | |
36 | (proc x))) | |
37 | ((_ arg) | |
38 | (begin body body* ...))))) | |
89f9dd70 | 39 | |
34ed9dfd | 40 | (define (fill-bytecode bv target-endianness) |
89f9dd70 AW |
41 | (let ((pos 0)) |
42 | (define-inline1 (write-byte b) | |
43 | (bytevector-u8-set! bv pos b) | |
44 | (set! pos (1+ pos))) | |
45 | (define u32-bv (make-bytevector 4)) | |
46 | (define-inline1 (write-int24-be x) | |
47 | (bytevector-s32-set! u32-bv 0 x (endianness big)) | |
48 | (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1)) | |
49 | (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2)) | |
50 | (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3)) | |
51 | (set! pos (+ pos 3))) | |
52 | (define-inline1 (write-uint32-be x) | |
53 | (bytevector-u32-set! bv pos x (endianness big)) | |
54 | (set! pos (+ pos 4))) | |
55 | (define-inline1 (write-uint32 x) | |
34ed9dfd | 56 | (bytevector-u32-set! bv pos x target-endianness) |
89f9dd70 AW |
57 | (set! pos (+ pos 4))) |
58 | (define-inline1 (write-loader-len len) | |
59 | (bytevector-u8-set! bv pos (ash len -16)) | |
60 | (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255)) | |
61 | (bytevector-u8-set! bv (+ pos 2) (logand len 255)) | |
62 | (set! pos (+ pos 3))) | |
63 | (define-inline1 (write-latin1-string s) | |
64 | (let ((len (string-length s))) | |
65 | (write-loader-len len) | |
66 | (let lp ((i 0)) | |
67 | (if (< i len) | |
68 | (begin | |
69 | (bytevector-u8-set! bv (+ pos i) | |
70 | (char->integer (string-ref s i))) | |
71 | (lp (1+ i))))) | |
72 | (set! pos (+ pos len)))) | |
73 | (define-inline1 (write-bytevector bv*) | |
74 | (let ((len (bytevector-length bv*))) | |
75 | (write-loader-len len) | |
76 | (bytevector-copy! bv* 0 bv pos len) | |
77 | (set! pos (+ pos len)))) | |
78 | (define-inline1 (write-wide-string s) | |
34ed9dfd | 79 | (write-bytevector (string->utf32 s target-endianness))) |
89f9dd70 AW |
80 | (define-inline1 (write-break label) |
81 | (let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) | |
82 | (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) | |
83 | ((< offset (- (ash 1 23))) (error "jump too far backwards" offset)) | |
84 | (else (write-int24-be offset))))) | |
53e28ed9 | 85 | |
89f9dd70 AW |
86 | (define (write-bytecode asm labels address emit-opcode?) |
87 | ;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't | |
88 | ;; emit bytecode for the first opcode encountered. Assume code | |
89 | ;; starts at ADDRESS (an integer). LABELS is assumed to be an | |
90 | ;; alist mapping labels to addresses. | |
91 | (define get-addr | |
92 | (let ((start pos)) | |
93 | (lambda () | |
94 | (+ address (- pos start))))) | |
95 | (define (write-break label) | |
96 | (let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) | |
97 | (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) | |
98 | ((< offset (- (ash 1 23))) (error "jump too far backwards" offset)) | |
99 | (else (write-int24-be offset))))) | |
53e28ed9 | 100 | |
89f9dd70 AW |
101 | (let ((inst (car asm)) |
102 | (args (cdr asm))) | |
103 | (let ((opcode (instruction->opcode inst)) | |
104 | (len (instruction-length inst))) | |
105 | (if emit-opcode? | |
106 | (write-byte opcode)) | |
107 | (pmatch asm | |
108 | ((load-program ,labels ,length ,meta . ,code) | |
109 | (write-uint32 length) | |
110 | (write-uint32 (if meta (1- (byte-length meta)) 0)) | |
111 | (fold (lambda (asm address) | |
112 | (let ((start pos)) | |
113 | (write-bytecode asm labels address #t) | |
114 | (+ address (- pos start)))) | |
115 | 0 | |
116 | code) | |
117 | (if meta | |
118 | ;; Don't emit the `load-program' byte for metadata. Note that | |
119 | ;; META's bytecode meets the alignment requirements of | |
120 | ;; `scm_objcode', thanks to the alignment computed in `(language | |
121 | ;; assembly)'. | |
122 | (write-bytecode meta '() 0 #f))) | |
123 | ((make-char32 ,x) (write-uint32-be x)) | |
124 | ((load-number ,str) (write-latin1-string str)) | |
125 | ((load-string ,str) (write-latin1-string str)) | |
126 | ((load-wide-string ,str) (write-wide-string str)) | |
127 | ((load-symbol ,str) (write-latin1-string str)) | |
128 | ((load-array ,bv) (write-bytevector bv)) | |
129 | ((br ,l) (write-break l)) | |
130 | ((br-if ,l) (write-break l)) | |
131 | ((br-if-not ,l) (write-break l)) | |
132 | ((br-if-eq ,l) (write-break l)) | |
133 | ((br-if-not-eq ,l) (write-break l)) | |
134 | ((br-if-null ,l) (write-break l)) | |
135 | ((br-if-not-null ,l) (write-break l)) | |
136 | ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) | |
137 | ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) | |
138 | ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) | |
581f410f AW |
139 | ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo |
140 | ,nreq-and-nopt-hi ,nreq-and-nopt-lo | |
141 | ,ntotal-hi ,ntotal-lo | |
142 | ,l) | |
143 | (write-byte nreq-hi) | |
144 | (write-byte nreq-lo) | |
145 | (write-byte nreq-and-nopt-hi) | |
146 | (write-byte nreq-and-nopt-lo) | |
147 | (write-byte ntotal-hi) | |
148 | (write-byte ntotal-lo) | |
149 | (write-break l)) | |
89f9dd70 AW |
150 | ((mv-call ,n ,l) (write-byte n) (write-break l)) |
151 | ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l)) | |
152 | (else | |
153 | (cond | |
154 | ((< len 0) | |
155 | (error "unhanded variable-length instruction" asm)) | |
156 | ((not (= (length args) len)) | |
157 | (error "bad number of args to instruction" asm len)) | |
158 | (else | |
159 | (for-each (lambda (x) (write-byte x)) args)))))))) | |
160 | ||
161 | ;; Don't emit the `load-program' byte. | |
162 | (write-bytecode assembly '() 0 #f) | |
163 | (if (= pos (bytevector-length bv)) | |
164 | (values bv env env) | |
165 | (error "failed to fill bytevector" bv pos | |
166 | (bytevector-length bv))))) | |
167 | ||
168 | (pmatch assembly | |
169 | ((load-program ,labels ,length ,meta . ,code) | |
170 | (fill-bytecode (make-bytevector (+ 4 4 length | |
171 | (if meta | |
172 | (1- (byte-length meta)) | |
34ed9dfd AW |
173 | 0))) |
174 | (target-endianness))) | |
175 | ||
89f9dd70 | 176 | (else (error "bad assembly" assembly)))) |