Commit | Line | Data |
---|---|---|
ba7e7139 | 1 | ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*- |
53e28ed9 | 2 | ;;;; |
cc2948aa | 3 | ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
e0a9f022 | 4 | ;;;; |
53e28ed9 AW |
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 | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
e0a9f022 | 9 | ;;;; |
53e28ed9 AW |
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. | |
e0a9f022 | 14 | ;;;; |
53e28ed9 AW |
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 | |
18 | ||
d10f7b57 | 19 | (define-module (tests asm-to-bytecode) |
07d22c02 | 20 | #:use-module (rnrs bytevectors) |
bde92e6b | 21 | #:use-module ((rnrs io ports) #:select (open-bytevector-output-port)) |
53e28ed9 AW |
22 | #:use-module (test-suite lib) |
23 | #:use-module (system vm instruction) | |
de2c0a10 | 24 | #:use-module (system vm objcode) |
e0a9f022 | 25 | #:use-module (system base target) |
89f9dd70 | 26 | #:use-module (language assembly) |
6f787028 | 27 | #:use-module (language assembly compile-bytecode)) |
53e28ed9 | 28 | |
ccf77d95 AW |
29 | (define (->u8-list sym val) |
30 | (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!) | |
31 | (uint32 4 ,bytevector-u32-native-set!)) | |
32 | sym))) | |
33 | (or entry (error "unknown sym" sym)) | |
34 | (let ((bv (make-bytevector (car entry)))) | |
35 | ((cadr entry) bv 0 val) | |
36 | (bytevector->u8-list bv)))) | |
37 | ||
53e28ed9 | 38 | (define (munge-bytecode v) |
ccf77d95 AW |
39 | (let lp ((i 0) (out '())) |
40 | (if (= i (vector-length v)) | |
bde92e6b | 41 | (u8-list->bytevector (reverse out)) |
ccf77d95 AW |
42 | (let ((x (vector-ref v i))) |
43 | (cond | |
44 | ((symbol? x) | |
45 | (lp (1+ i) (cons (instruction->opcode x) out))) | |
46 | ((integer? x) | |
47 | (lp (1+ i) (cons x out))) | |
48 | ((pair? x) | |
49 | (lp (1+ i) (append (reverse (apply ->u8-list x)) out))) | |
50 | (else (error "bad test bytecode" x))))))) | |
53e28ed9 AW |
51 | |
52 | (define (comp-test x y) | |
bde92e6b LC |
53 | (let* ((y (munge-bytecode y)) |
54 | (len (bytevector-length y)) | |
55 | (v #f)) | |
56 | ||
53e28ed9 AW |
57 | (run-test `(length ,x) #t |
58 | (lambda () | |
89f9dd70 AW |
59 | (let* ((wrapped `(load-program () ,(byte-length x) #f ,x)) |
60 | (bv (compile-bytecode wrapped '()))) | |
61 | (set! v (make-bytevector (- (bytevector-length bv) 8))) | |
62 | (bytevector-copy! bv 8 v 0 (bytevector-length v)) | |
63 | (= (bytevector-length v) len)))) | |
53e28ed9 AW |
64 | (run-test `(compile-equal? ,x ,y) #t |
65 | (lambda () | |
66 | (equal? v y))))) | |
67 | ||
44362a10 | 68 | \f |
53e28ed9 AW |
69 | (with-test-prefix "compiler" |
70 | (with-test-prefix "asm-to-bytecode" | |
71 | ||
72 | (comp-test '(make-int8 3) | |
73 | #(make-int8 3)) | |
74 | ||
53e28ed9 AW |
75 | (comp-test '(load-number "3.14") |
76 | (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.) | |
77 | (char->integer #\1) (char->integer #\4))) | |
78 | ||
79 | (comp-test '(load-string "foo") | |
94ff26b9 | 80 | (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o) |
53e28ed9 AW |
81 | (char->integer #\o))) |
82 | ||
83 | (comp-test '(load-symbol "foo") | |
94ff26b9 | 84 | (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o) |
53e28ed9 | 85 | (char->integer #\o))) |
1caa6341 | 86 | |
ba7e7139 | 87 | (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string |
1caa6341 LC |
88 | (vector 'load-string 0 0 1 230)) |
89 | ||
ba7e7139 LC |
90 | (comp-test '(load-wide-string "λ") |
91 | (apply vector 'load-wide-string 0 0 4 | |
92 | (if (eq? (native-endianness) (endianness little)) | |
93 | '(187 3 0 0) | |
94 | '(0 0 3 187)))) | |
95 | ||
56164a5a | 96 | (comp-test '(load-program () 3 #f (make-int8 3) (return)) |
ccf77d95 | 97 | #(load-program |
ccf77d95 AW |
98 | (uint32 3) ;; len |
99 | (uint32 0) ;; metalen | |
100 | make-int8 3 | |
101 | return)) | |
1f1ec13b | 102 | |
28b119ee AW |
103 | ;; the nops are to pad meta to an 8-byte alignment. not strictly |
104 | ;; necessary for this test, but representative of the common case. | |
56164a5a AW |
105 | (comp-test '(load-program () 8 |
106 | (load-program () 3 | |
1f1ec13b AW |
107 | #f |
108 | (make-int8 3) (return)) | |
28b119ee AW |
109 | (make-int8 3) (return) |
110 | (nop) (nop) (nop) (nop) (nop)) | |
ccf77d95 | 111 | #(load-program |
28b119ee | 112 | (uint32 8) ;; len |
56164a5a | 113 | (uint32 11) ;; metalen |
ccf77d95 AW |
114 | make-int8 3 |
115 | return | |
28b119ee | 116 | nop nop nop nop nop |
ccf77d95 AW |
117 | (uint32 3) ;; len |
118 | (uint32 0) ;; metalen | |
119 | make-int8 3 | |
120 | return)))) | |
e0a9f022 LC |
121 | |
122 | \f | |
123 | (define (test-triplet cpu vendor os) | |
124 | (let ((triplet (string-append cpu "-" vendor "-" os))) | |
125 | (pass-if (format #f "triplet ~a" triplet) | |
126 | (with-target triplet | |
127 | (lambda () | |
128 | (and (string=? (target-cpu) cpu) | |
129 | (string=? (target-vendor) vendor) | |
130 | (string=? (target-os) os))))))) | |
131 | ||
17cc6e40 LC |
132 | (define (native-cpu) |
133 | (with-target %host-type target-cpu)) | |
134 | ||
aacc6896 LC |
135 | (define (native-os) |
136 | (with-target %host-type target-os)) | |
137 | ||
17cc6e40 LC |
138 | (define (native-word-size) |
139 | ((@ (system foreign) sizeof) '*)) | |
140 | ||
de2c0a10 LC |
141 | (define %objcode-cookie-size |
142 | (string-length "GOOF----LE-8-2.0")) | |
143 | ||
144 | (define (test-target triplet endian word-size) | |
145 | (pass-if (format #f "target `~a' honored" triplet) | |
146 | (call-with-values (lambda () | |
147 | (open-bytevector-output-port)) | |
148 | (lambda (p get-objcode) | |
149 | (with-target triplet | |
150 | (lambda () | |
17cc6e40 LC |
151 | (let ((word-size |
152 | ;; When the target is the native CPU, rather trust | |
153 | ;; the native CPU's word size. This is because | |
154 | ;; Debian's `sparc64-linux-gnu' port, for instance, | |
155 | ;; actually has a 32-bit user-land, for instance (see | |
156 | ;; <http://www.debian.org/ports/sparc/#sparc64bit> | |
157 | ;; for details.) | |
aacc6896 LC |
158 | (if (and (string=? (native-cpu) (target-cpu)) |
159 | (string=? (native-os) (target-os))) | |
17cc6e40 LC |
160 | (native-word-size) |
161 | word-size)) | |
162 | (b (compile-bytecode | |
de2c0a10 LC |
163 | '(load-program () 16 #f |
164 | (assert-nargs-ee/locals 1) | |
165 | (make-int8 77) | |
166 | (toplevel-ref 1) | |
167 | (local-ref 0) | |
168 | (mul) | |
169 | (add) | |
170 | (return) | |
171 | (nop) (nop) (nop) | |
172 | (nop) (nop)) | |
173 | #f))) | |
174 | (write-objcode (bytecode->objcode b) p) | |
175 | (let ((cookie (make-bytevector %objcode-cookie-size)) | |
176 | (expected (format #f "GOOF----~a-~a-~a" | |
177 | (cond ((eq? endian (endianness little)) | |
178 | "LE") | |
179 | ((eq? endian (endianness big)) | |
180 | "BE") | |
181 | (else | |
182 | (error "unknown endianness" | |
183 | endian))) | |
184 | word-size | |
185 | (effective-version)))) | |
186 | (bytevector-copy! (get-objcode) 0 cookie 0 | |
187 | %objcode-cookie-size) | |
188 | (string=? (utf8->string cookie) expected))))))))) | |
189 | ||
e0a9f022 LC |
190 | (with-test-prefix "cross-compilation" |
191 | ||
192 | (test-triplet "i586" "pc" "gnu0.3") | |
193 | (test-triplet "x86_64" "unknown" "linux-gnu") | |
de2c0a10 LC |
194 | (test-triplet "x86_64" "unknown" "kfreebsd-gnu") |
195 | ||
196 | (test-target "i586-pc-gnu0.3" (endianness little) 4) | |
197 | (test-target "x86_64-pc-linux-gnu" (endianness little) 8) | |
198 | (test-target "powerpc-unknown-linux-gnu" (endianness big) 4) | |
199 | (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8) | |
200 | ||
cc2948aa LC |
201 | (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI |
202 | (endianness little) 4) | |
9130ec74 LC |
203 | (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet) |
204 | (endianness little) 8) | |
b946e08a LC |
205 | (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet) |
206 | (endianness little) 4) | |
cc2948aa | 207 | |
de2c0a10 LC |
208 | (pass-if-exception "unknown target" |
209 | exception:miscellaneous-error | |
210 | (call-with-values (lambda () | |
211 | (open-bytevector-output-port)) | |
212 | (lambda (p get-objcode) | |
213 | (let* ((b (compile-bytecode '(load-program () 3 #f | |
214 | (make-int8 77) | |
215 | (return)) | |
216 | #f)) | |
217 | (o (bytecode->objcode b))) | |
218 | (with-target "fcpu-unknown-gnu1.0" | |
219 | (lambda () | |
220 | (write-objcode o p)))))))) | |
e0a9f022 LC |
221 | |
222 | ;; Local Variables: | |
223 | ;; eval: (put 'with-target 'scheme-indent-function 1) | |
224 | ;; End: |