Commit | Line | Data |
---|---|---|
ba7e7139 | 1 | ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*- |
53e28ed9 | 2 | ;;;; |
e0a9f022 LC |
3 | ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
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 | ||
19 | (define-module (test-suite 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 | ||
de2c0a10 LC |
132 | (define %objcode-cookie-size |
133 | (string-length "GOOF----LE-8-2.0")) | |
134 | ||
135 | (define (test-target triplet endian word-size) | |
136 | (pass-if (format #f "target `~a' honored" triplet) | |
137 | (call-with-values (lambda () | |
138 | (open-bytevector-output-port)) | |
139 | (lambda (p get-objcode) | |
140 | (with-target triplet | |
141 | (lambda () | |
142 | (let ((b (compile-bytecode | |
143 | '(load-program () 16 #f | |
144 | (assert-nargs-ee/locals 1) | |
145 | (make-int8 77) | |
146 | (toplevel-ref 1) | |
147 | (local-ref 0) | |
148 | (mul) | |
149 | (add) | |
150 | (return) | |
151 | (nop) (nop) (nop) | |
152 | (nop) (nop)) | |
153 | #f))) | |
154 | (write-objcode (bytecode->objcode b) p) | |
155 | (let ((cookie (make-bytevector %objcode-cookie-size)) | |
156 | (expected (format #f "GOOF----~a-~a-~a" | |
157 | (cond ((eq? endian (endianness little)) | |
158 | "LE") | |
159 | ((eq? endian (endianness big)) | |
160 | "BE") | |
161 | (else | |
162 | (error "unknown endianness" | |
163 | endian))) | |
164 | word-size | |
165 | (effective-version)))) | |
166 | (bytevector-copy! (get-objcode) 0 cookie 0 | |
167 | %objcode-cookie-size) | |
168 | (string=? (utf8->string cookie) expected))))))))) | |
169 | ||
e0a9f022 LC |
170 | (with-test-prefix "cross-compilation" |
171 | ||
172 | (test-triplet "i586" "pc" "gnu0.3") | |
173 | (test-triplet "x86_64" "unknown" "linux-gnu") | |
de2c0a10 LC |
174 | (test-triplet "x86_64" "unknown" "kfreebsd-gnu") |
175 | ||
176 | (test-target "i586-pc-gnu0.3" (endianness little) 4) | |
177 | (test-target "x86_64-pc-linux-gnu" (endianness little) 8) | |
178 | (test-target "powerpc-unknown-linux-gnu" (endianness big) 4) | |
179 | (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8) | |
180 | ||
181 | (pass-if-exception "unknown target" | |
182 | exception:miscellaneous-error | |
183 | (call-with-values (lambda () | |
184 | (open-bytevector-output-port)) | |
185 | (lambda (p get-objcode) | |
186 | (let* ((b (compile-bytecode '(load-program () 3 #f | |
187 | (make-int8 77) | |
188 | (return)) | |
189 | #f)) | |
190 | (o (bytecode->objcode b))) | |
191 | (with-target "fcpu-unknown-gnu1.0" | |
192 | (lambda () | |
193 | (write-objcode o p)))))))) | |
e0a9f022 LC |
194 | |
195 | ;; Local Variables: | |
196 | ;; eval: (put 'with-target 'scheme-indent-function 1) | |
197 | ;; End: |