;;;; 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 base target) #: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))))) (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)))) (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-2.0")) (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 ;; ;; 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) p) (let ((cookie (make-bytevector %objcode-cookie-size)) (expected (format #f "GOOF----~a-~a-~a" (cond ((eq? endian (endianness little)) "LE") ((eq? endian (endianness big)) "BE") (else (error "unknown endianness" endian))) word-size (effective-version)))) (bytevector-copy! (get-objcode) 0 cookie 0 %objcode-cookie-size) (string=? (utf8->string cookie) expected))))))))) (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) (test-target "arm-unknown-linux-androideabi" (endianness little) 4) (test-target "armeb-unknown-linux-gnu" (endianness big) 4) (test-target "aarch64-linux-gnu" (endianness little) 8) (test-target "aarch64_be-linux-gnu" (endianness big) 8) (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))) (with-target "fcpu-unknown-gnu1.0" (lambda () (write-objcode o p)))))))) ;; Local Variables: ;; eval: (put 'with-target 'scheme-indent-function 1) ;; End: