+++ /dev/null
-;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
-;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-(define-module (tests asm-to-bytecode)
- #:use-module (rnrs bytevectors)
- #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
- #:use-module (test-suite lib)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
- #:use-module (system vm elf)
- #:use-module (system base target)
- #:use-module (language objcode elf)
- #:use-module (language assembly)
- #:use-module (language assembly compile-bytecode))
-
-(define (->u8-list sym val)
- (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
- (uint32 4 ,bytevector-u32-native-set!))
- sym)))
- (or entry (error "unknown sym" sym))
- (let ((bv (make-bytevector (car entry))))
- ((cadr entry) bv 0 val)
- (bytevector->u8-list bv))))
-
-(define (munge-bytecode v)
- (let lp ((i 0) (out '()))
- (if (= i (vector-length v))
- (u8-list->bytevector (reverse out))
- (let ((x (vector-ref v i)))
- (cond
- ((symbol? x)
- (lp (1+ i) (cons (instruction->opcode x) out)))
- ((integer? x)
- (lp (1+ i) (cons x out)))
- ((pair? x)
- (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
- (else (error "bad test bytecode" x)))))))
-
-(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (bytevector-length y))
- (v #f))
-
- (run-test `(length ,x) #t
- (lambda ()
- (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
- (bv (compile-bytecode wrapped '())))
- (set! v (make-bytevector (- (bytevector-length bv) 8)))
- (bytevector-copy! bv 8 v 0 (bytevector-length v))
- (= (bytevector-length v) len))))
- (run-test `(compile-equal? ,x ,y) #t
- (lambda ()
- (equal? v y)))))
-
-\f
-(with-test-prefix "compiler"
- (with-test-prefix "asm-to-bytecode"
-
- (comp-test '(make-int8 3)
- #(make-int8 3))
-
- (comp-test '(load-number "3.14")
- (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
- (char->integer #\1) (char->integer #\4)))
-
- (comp-test '(load-string "foo")
- (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-symbol "foo")
- (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
- (vector 'load-string 0 0 1 230))
-
- (comp-test '(load-wide-string "λ")
- (apply vector 'load-wide-string 0 0 4
- (if (eq? (native-endianness) (endianness little))
- '(187 3 0 0)
- '(0 0 3 187))))
-
- (comp-test '(load-program () 3 #f (make-int8 3) (return))
- #(load-program
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))
-
- ;; the nops are to pad meta to an 8-byte alignment. not strictly
- ;; necessary for this test, but representative of the common case.
- (comp-test '(load-program () 8
- (load-program () 3
- #f
- (make-int8 3) (return))
- (make-int8 3) (return)
- (nop) (nop) (nop) (nop) (nop))
- #(load-program
- (uint32 8) ;; len
- (uint32 11) ;; metalen
- make-int8 3
- return
- nop nop nop nop nop
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))))
-
-\f
-(define (test-triplet cpu vendor os)
- (let ((triplet (string-append cpu "-" vendor "-" os)))
- (pass-if (format #f "triplet ~a" triplet)
- (with-target triplet
- (lambda ()
- (and (string=? (target-cpu) cpu)
- (string=? (target-vendor) vendor)
- (string=? (target-os) os)))))))
-
-(define (native-cpu)
- (with-target %host-type target-cpu))
-
-(define (native-os)
- (with-target %host-type target-os))
-
-(define (native-word-size)
- ((@ (system foreign) sizeof) '*))
-
-(define %objcode-cookie-size
- (string-length "GOOF----LE-8"))
-
-(define (test-target triplet endian word-size)
- (pass-if (format #f "target `~a' honored" triplet)
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (with-target triplet
- (lambda ()
- (let ((word-size
- ;; When the target is the native CPU, rather trust
- ;; the native CPU's word size. This is because
- ;; Debian's `sparc64-linux-gnu' port, for instance,
- ;; actually has a 32-bit user-land, for instance (see
- ;; <http://www.debian.org/ports/sparc/#sparc64bit>
- ;; for details.)
- (if (and (string=? (native-cpu) (target-cpu))
- (string=? (native-os) (target-os)))
- (native-word-size)
- word-size))
- (b (compile-bytecode
- '(load-program () 16 #f
- (assert-nargs-ee/locals 1)
- (make-int8 77)
- (toplevel-ref 1)
- (local-ref 0)
- (mul)
- (add)
- (return)
- (nop) (nop) (nop)
- (nop) (nop))
- #f)))
- (write-objcode (bytecode->objcode b (target-endianness)) p)
- (let* ((bv (get-objcode)))
- (and=> (parse-elf bv)
- (lambda (elf)
- (and (equal? (elf-byte-order elf) endian)
- (equal? (elf-word-size elf) word-size))))))))))))
-
-(with-test-prefix "cross-compilation"
-
- (test-triplet "i586" "pc" "gnu0.3")
- (test-triplet "x86_64" "unknown" "linux-gnu")
- (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
-
- (test-target "i586-pc-gnu0.3" (endianness little) 4)
- (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
- (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
- (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
-
- (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
- (endianness little) 4)
- (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
- (endianness little) 8)
- (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
- (endianness little) 4)
-
- (pass-if-exception "unknown target"
- exception:miscellaneous-error
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (let* ((b (compile-bytecode '(load-program () 3 #f
- (make-int8 77)
- (return))
- #f))
- (o (bytecode->objcode b (target-endianness))))
- (with-target "fcpu-unknown-gnu1.0"
- (lambda ()
- (write-objcode o p))))))))
-
-;; Local Variables:
-;; eval: (put 'with-target 'scheme-indent-function 1)
-;; End:
--- /dev/null
+;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (tests cross-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm elf)
+ #:use-module (system base compile)
+ #:use-module (system base target))
+
+(define (test-triplet cpu vendor os)
+ (let ((triplet (string-append cpu "-" vendor "-" os)))
+ (pass-if (format #f "triplet ~a" triplet)
+ (with-target triplet
+ (lambda ()
+ (and (string=? (target-cpu) cpu)
+ (string=? (target-vendor) vendor)
+ (string=? (target-os) os)))))))
+
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-os)
+ (with-target %host-type target-os))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (with-target triplet
+ (lambda ()
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
+ (native-word-size)
+ word-size))
+ (bv (compile '(hello-world) #:to 'rtl)))
+ (and=> (parse-elf bv)
+ (lambda (elf)
+ (and (equal? (elf-byte-order elf) endian)
+ (equal? (elf-word-size elf) word-size)))))))))
+
+(with-test-prefix "cross-compilation"
+
+ (test-triplet "i586" "pc" "gnu0.3")
+ (test-triplet "x86_64" "unknown" "linux-gnu")
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'rtl)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
HCoop / bpt / guile.git / commitdiff