1 ;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (test-suite tests asm-to-bytecode)
20 #:use-module (rnrs bytevectors)
21 #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
22 #:use-module (test-suite lib)
23 #:use-module (system vm instruction)
24 #:use-module (system vm objcode)
25 #:use-module (system base target)
26 #:use-module (language assembly)
27 #:use-module (language assembly compile-bytecode))
29 (define (->u8-list sym val)
30 (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
31 (uint32 4 ,bytevector-u32-native-set!))
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))))
38 (define (munge-bytecode v)
39 (let lp ((i 0) (out '()))
40 (if (= i (vector-length v))
41 (u8-list->bytevector (reverse out))
42 (let ((x (vector-ref v i)))
45 (lp (1+ i) (cons (instruction->opcode x) out)))
47 (lp (1+ i) (cons x out)))
49 (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
50 (else (error "bad test bytecode" x)))))))
52 (define (comp-test x y)
53 (let* ((y (munge-bytecode y))
54 (len (bytevector-length y))
57 (run-test `(length ,x) #t
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))))
64 (run-test `(compile-equal? ,x ,y) #t
69 (with-test-prefix "compiler"
70 (with-test-prefix "asm-to-bytecode"
72 (comp-test '(make-int8 3)
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)))
79 (comp-test '(load-string "foo")
80 (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
83 (comp-test '(load-symbol "foo")
84 (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
87 (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
88 (vector 'load-string 0 0 1 230))
90 (comp-test '(load-wide-string "λ")
91 (apply vector 'load-wide-string 0 0 4
92 (if (eq? (native-endianness) (endianness little))
96 (comp-test '(load-program () 3 #f (make-int8 3) (return))
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.
105 (comp-test '(load-program () 8
108 (make-int8 3) (return))
109 (make-int8 3) (return)
110 (nop) (nop) (nop) (nop) (nop))
113 (uint32 11) ;; metalen
118 (uint32 0) ;; metalen
123 (define (test-triplet cpu vendor os)
124 (let ((triplet (string-append cpu "-" vendor "-" os)))
125 (pass-if (format #f "triplet ~a" triplet)
128 (and (string=? (target-cpu) cpu)
129 (string=? (target-vendor) vendor)
130 (string=? (target-os) os)))))))
133 (with-target %host-type target-cpu))
135 (define (native-word-size)
136 ((@ (system foreign) sizeof) '*))
138 (define %objcode-cookie-size
139 (string-length "GOOF----LE-8-2.0"))
141 (define (test-target triplet endian word-size)
142 (pass-if (format #f "target `~a' honored" triplet)
143 (call-with-values (lambda ()
144 (open-bytevector-output-port))
145 (lambda (p get-objcode)
149 ;; When the target is the native CPU, rather trust
150 ;; the native CPU's word size. This is because
151 ;; Debian's `sparc64-linux-gnu' port, for instance,
152 ;; actually has a 32-bit user-land, for instance (see
153 ;; <http://www.debian.org/ports/sparc/#sparc64bit>
155 (if (string=? (native-cpu) (target-cpu))
159 '(load-program () 16 #f
160 (assert-nargs-ee/locals 1)
170 (write-objcode (bytecode->objcode b) p)
171 (let ((cookie (make-bytevector %objcode-cookie-size))
172 (expected (format #f "GOOF----~a-~a-~a"
173 (cond ((eq? endian (endianness little))
175 ((eq? endian (endianness big))
178 (error "unknown endianness"
181 (effective-version))))
182 (bytevector-copy! (get-objcode) 0 cookie 0
183 %objcode-cookie-size)
184 (string=? (utf8->string cookie) expected)))))))))
186 (with-test-prefix "cross-compilation"
188 (test-triplet "i586" "pc" "gnu0.3")
189 (test-triplet "x86_64" "unknown" "linux-gnu")
190 (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
192 (test-target "i586-pc-gnu0.3" (endianness little) 4)
193 (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
194 (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
195 (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
197 (pass-if-exception "unknown target"
198 exception:miscellaneous-error
199 (call-with-values (lambda ()
200 (open-bytevector-output-port))
201 (lambda (p get-objcode)
202 (let* ((b (compile-bytecode '(load-program () 3 #f
206 (o (bytecode->objcode b)))
207 (with-target "fcpu-unknown-gnu1.0"
209 (write-objcode o p))))))))
212 ;; eval: (put 'with-target 'scheme-indent-function 1)