mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Add RTL assembler
* module/Makefile.am: * module/system/vm/assembler.scm: New module, implementing an assembler for RTL. * test-suite/Makefile.am: * test-suite/tests/rtl.test: New test suite. * module/system/vm/elf.scm (make-elf-symbol*): Add constructor; export as make-elf-symbol. (elf-symbol-len): New export. (write-elf32-symbol, write-elf64-symbol): New helpers. (write-elf-symbol): New export.
This commit is contained in:
Andy Wingo
parent
f5473fbaaf
commit
e78991aa36
5 changed files with 1379 additions and 1 deletions
|
|
@ -356,6 +356,7 @@ SYSTEM_SOURCES = \
|
|||
system/vm/trace.scm \
|
||||
system/vm/traps.scm \
|
||||
system/vm/trap-state.scm \
|
||||
system/vm/assembler.scm \
|
||||
system/vm/vm.scm \
|
||||
system/foreign.scm \
|
||||
system/xref.scm \
|
||||
|
|
|
|||
1088
module/system/vm/assembler.scm
Normal file
1088
module/system/vm/assembler.scm
Normal file
File diff suppressed because it is too large
Load diff
|
|
@ -77,11 +77,14 @@
|
|||
elf-section-header-offset-offset
|
||||
write-elf-section-header
|
||||
|
||||
make-elf-symbol elf-symbol?
|
||||
(make-elf-symbol* . make-elf-symbol)
|
||||
elf-symbol?
|
||||
elf-symbol-name elf-symbol-value elf-symbol-size
|
||||
elf-symbol-info elf-symbol-other elf-symbol-shndx
|
||||
elf-symbol-binding elf-symbol-type elf-symbol-visibility
|
||||
|
||||
elf-symbol-len write-elf-symbol
|
||||
|
||||
SHN_UNDEF
|
||||
|
||||
SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
|
||||
|
|
@ -812,6 +815,13 @@
|
|||
(other elf-symbol-other)
|
||||
(shndx elf-symbol-shndx))
|
||||
|
||||
(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
|
||||
(binding STB_LOCAL) (type STT_NOTYPE)
|
||||
(info (logior (ash binding 4) type))
|
||||
(visibility STV_DEFAULT) (other visibility)
|
||||
(shndx SHN_UNDEF))
|
||||
(make-elf-symbol name value size info other shndx))
|
||||
|
||||
;; typedef struct {
|
||||
;; uint32_t st_name;
|
||||
;; Elf32_Addr st_value;
|
||||
|
|
@ -821,6 +831,12 @@
|
|||
;; uint16_t st_shndx;
|
||||
;; } Elf32_Sym;
|
||||
|
||||
(define (elf-symbol-len word-size)
|
||||
(case word-size
|
||||
((4) 16)
|
||||
((8) 24)
|
||||
(else (error "bad word size" word-size))))
|
||||
|
||||
(define (parse-elf32-symbol bv offset stroff byte-order)
|
||||
(if (<= (+ offset 16) (bytevector-length bv))
|
||||
(make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
|
||||
|
|
@ -834,6 +850,14 @@
|
|||
(bytevector-u16-ref bv (+ offset 14) byte-order))
|
||||
(error "corrupt ELF (offset out of range)" offset)))
|
||||
|
||||
(define (write-elf32-symbol bv offset byte-order sym)
|
||||
(bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
|
||||
(bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
|
||||
(bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
|
||||
(bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
|
||||
(bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
|
||||
(bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
|
||||
|
||||
;; typedef struct {
|
||||
;; uint32_t st_name;
|
||||
;; unsigned char st_info;
|
||||
|
|
@ -856,6 +880,21 @@
|
|||
(bytevector-u16-ref bv (+ offset 6) byte-order))
|
||||
(error "corrupt ELF (offset out of range)" offset)))
|
||||
|
||||
(define (write-elf64-symbol bv offset byte-order sym)
|
||||
(bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
|
||||
(bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
|
||||
(bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
|
||||
(bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
|
||||
(bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
|
||||
(bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
|
||||
|
||||
(define (write-elf-symbol bv offset byte-order word-size sym)
|
||||
((case word-size
|
||||
((4) write-elf32-symbol)
|
||||
((8) write-elf64-symbol)
|
||||
(else (error "invalid word size" word-size)))
|
||||
bv offset byte-order sym))
|
||||
|
||||
(define* (elf-symbol-table-ref elf section n #:optional strtab)
|
||||
(let ((bv (elf-bytes elf))
|
||||
(byte-order (elf-byte-order elf))
|
||||
|
|
|
|||
|
|
@ -114,6 +114,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/reader.test \
|
||||
tests/receive.test \
|
||||
tests/regexp.test \
|
||||
tests/rtl.test \
|
||||
tests/session.test \
|
||||
tests/signals.test \
|
||||
tests/srcprop.test \
|
||||
|
|
|
|||
249
test-suite/tests/rtl.test
Normal file
249
test-suite/tests/rtl.test
Normal file
|
|
@ -0,0 +1,249 @@
|
|||
;;;; Low-level tests of the RTL assembler -*- 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 rtl)
|
||||
#:use-module (test-suite lib)
|
||||
#:use-module (system vm assembler))
|
||||
|
||||
(define-syntax-rule (assert-equal val expr)
|
||||
(let ((x val))
|
||||
(pass-if (object->string x) (equal? expr x))))
|
||||
|
||||
(define (return-constant val)
|
||||
(assemble-program `((begin-program foo)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(load-constant 0 ,val)
|
||||
(return 0)
|
||||
(end-program))))
|
||||
|
||||
(define-syntax-rule (assert-constants val ...)
|
||||
(begin
|
||||
(assert-equal val ((return-constant val)))
|
||||
...))
|
||||
|
||||
(with-test-prefix "load-constant"
|
||||
(assert-constants
|
||||
1
|
||||
-1
|
||||
0
|
||||
most-positive-fixnum
|
||||
most-negative-fixnum
|
||||
#t
|
||||
#\c
|
||||
(integer->char 16000)
|
||||
3.14
|
||||
"foo"
|
||||
'foo
|
||||
#:foo
|
||||
"æ" ;; a non-ASCII Latin-1 string
|
||||
"λ" ;; non-ascii, non-latin-1
|
||||
'(1 . 2)
|
||||
'(1 2 3 4)
|
||||
#(1 2 3)
|
||||
#("foo" "bar" 'baz)
|
||||
;; FIXME: Add tests for arrays (uniform and otherwise)
|
||||
))
|
||||
|
||||
(with-test-prefix "static procedure"
|
||||
(assert-equal 42
|
||||
(((assemble-program `((begin-program foo)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(load-static-procedure 0 bar)
|
||||
(return 0)
|
||||
(end-program)
|
||||
(begin-program bar)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(load-constant 0 42)
|
||||
(return 0)
|
||||
(end-program)))))))
|
||||
|
||||
(with-test-prefix "loop"
|
||||
(assert-equal (* 999 500)
|
||||
(let ((sumto
|
||||
(assemble-program
|
||||
;; 0: limit
|
||||
;; 1: n
|
||||
;; 2: accum
|
||||
'((begin-program countdown)
|
||||
(assert-nargs-ee/locals 1 2)
|
||||
(br fix-body)
|
||||
(label loop-head)
|
||||
(br-if-= 1 0 out)
|
||||
(add 2 1 2)
|
||||
(add1 1 1)
|
||||
(br loop-head)
|
||||
(label fix-body)
|
||||
(load-constant 1 0)
|
||||
(load-constant 2 0)
|
||||
(br loop-head)
|
||||
(label out)
|
||||
(return 2)
|
||||
(end-program)))))
|
||||
(sumto 1000))))
|
||||
|
||||
(with-test-prefix "accum"
|
||||
(assert-equal (+ 1 2 3)
|
||||
(let ((make-accum
|
||||
(assemble-program
|
||||
;; 0: elt
|
||||
;; 1: tail
|
||||
;; 2: head
|
||||
'((begin-program make-accum)
|
||||
(assert-nargs-ee/locals 0 2)
|
||||
(load-constant 0 0)
|
||||
(box 0 0)
|
||||
(make-closure 1 accum (0))
|
||||
(return 1)
|
||||
(end-program)
|
||||
(begin-program accum)
|
||||
(assert-nargs-ee/locals 1 2)
|
||||
(free-ref 1 0)
|
||||
(box-ref 2 1)
|
||||
(add 2 2 0)
|
||||
(box-set! 1 2)
|
||||
(return 2)
|
||||
(end-program)))))
|
||||
(let ((accum (make-accum)))
|
||||
(accum 1)
|
||||
(accum 2)
|
||||
(accum 3)))))
|
||||
|
||||
(with-test-prefix "call"
|
||||
(assert-equal 42
|
||||
(let ((call ;; (lambda (x) (x))
|
||||
(assemble-program
|
||||
'((begin-program call)
|
||||
(assert-nargs-ee/locals 1 0)
|
||||
(call 1 0 ())
|
||||
(return 1) ;; MVRA from call
|
||||
(return 1) ;; RA from call
|
||||
(end-program)))))
|
||||
(call (lambda () 42))))
|
||||
|
||||
(assert-equal 6
|
||||
(let ((call-with-3 ;; (lambda (x) (x 3))
|
||||
(assemble-program
|
||||
'((begin-program call-with-3)
|
||||
(assert-nargs-ee/locals 1 1)
|
||||
(load-constant 1 3)
|
||||
(call 2 0 (1))
|
||||
(return 2) ;; MVRA from call
|
||||
(return 2) ;; RA from call
|
||||
(end-program)))))
|
||||
(call-with-3 (lambda (x) (* x 2))))))
|
||||
|
||||
(with-test-prefix "tail-call"
|
||||
(assert-equal 3
|
||||
(let ((call ;; (lambda (x) (x))
|
||||
(assemble-program
|
||||
'((begin-program call)
|
||||
(assert-nargs-ee/locals 1 0)
|
||||
(tail-call 0 0)
|
||||
(end-program)))))
|
||||
(call (lambda () 3))))
|
||||
|
||||
(assert-equal 6
|
||||
(let ((call-with-3 ;; (lambda (x) (x 3))
|
||||
(assemble-program
|
||||
'((begin-program call-with-3)
|
||||
(assert-nargs-ee/locals 1 1)
|
||||
(mov 1 0) ;; R1 <- R0
|
||||
(load-constant 0 3) ;; R0 <- 3
|
||||
(tail-call 1 1)
|
||||
(end-program)))))
|
||||
(call-with-3 (lambda (x) (* x 2))))))
|
||||
|
||||
(with-test-prefix "cached-toplevel-ref"
|
||||
(assert-equal 5.0
|
||||
(let ((get-sqrt-trampoline
|
||||
(assemble-program
|
||||
'((begin-program get-sqrt-trampoline)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(cache-current-module! 0 sqrt-scope)
|
||||
(load-static-procedure 0 sqrt-trampoline)
|
||||
(return 0)
|
||||
(end-program)
|
||||
|
||||
(begin-program sqrt-trampoline)
|
||||
(assert-nargs-ee/locals 1 1)
|
||||
(cached-toplevel-ref 1 sqrt-scope sqrt)
|
||||
(tail-call 1 1)
|
||||
(end-program)))))
|
||||
((get-sqrt-trampoline) 25.0))))
|
||||
|
||||
(define *top-val* 0)
|
||||
|
||||
(with-test-prefix "cached-toplevel-set!"
|
||||
(let ((prev *top-val*))
|
||||
(assert-equal (1+ prev)
|
||||
(let ((make-top-incrementor
|
||||
(assemble-program
|
||||
'((begin-program make-top-incrementor)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(cache-current-module! 0 top-incrementor)
|
||||
(load-static-procedure 0 top-incrementor)
|
||||
(return 0)
|
||||
(end-program)
|
||||
|
||||
(begin-program top-incrementor)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(cached-toplevel-ref 0 top-incrementor *top-val*)
|
||||
(add1 0 0)
|
||||
(cached-toplevel-set! 0 top-incrementor *top-val*)
|
||||
(return/values 0)
|
||||
(end-program)))))
|
||||
((make-top-incrementor))
|
||||
*top-val*))))
|
||||
|
||||
(with-test-prefix "cached-module-ref"
|
||||
(assert-equal 5.0
|
||||
(let ((get-sqrt-trampoline
|
||||
(assemble-program
|
||||
'((begin-program get-sqrt-trampoline)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(load-static-procedure 0 sqrt-trampoline)
|
||||
(return 0)
|
||||
(end-program)
|
||||
|
||||
(begin-program sqrt-trampoline)
|
||||
(assert-nargs-ee/locals 1 1)
|
||||
(cached-module-ref 1 (guile) #t sqrt)
|
||||
(tail-call 1 1)
|
||||
(end-program)))))
|
||||
((get-sqrt-trampoline) 25.0))))
|
||||
|
||||
(with-test-prefix "cached-module-set!"
|
||||
(let ((prev *top-val*))
|
||||
(assert-equal (1+ prev)
|
||||
(let ((make-top-incrementor
|
||||
(assemble-program
|
||||
'((begin-program make-top-incrementor)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(load-static-procedure 0 top-incrementor)
|
||||
(return 0)
|
||||
(end-program)
|
||||
|
||||
(begin-program top-incrementor)
|
||||
(assert-nargs-ee/locals 0 1)
|
||||
(cached-module-ref 0 (tests rtl) #f *top-val*)
|
||||
(add1 0 0)
|
||||
(cached-module-set! 0 (tests rtl) #f *top-val*)
|
||||
(return 0)
|
||||
(end-program)))))
|
||||
((make-top-incrementor))
|
||||
*top-val*))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue