mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-30 00:40:20 +02:00
66ff15e2f0
* module/Makefile.am: Add language/sassy.scm. Probably EXTRA_DIST the dependant files, too. * module/language/sassy.scm: New file, the sassy loader. Sassy is originally R5RS code that loads a number of files. I've converted that toplevel file to be a Guile module that *includes* the subfiles, so that it all gets compiled together. It's a pretty bad hack though, because what I should be doing is including them relative to the sassy.scm source location, but we don't know that at expansion time. Something to fix. really bad hack in it so that it will compile correctly -- p * module/language/sassy/: All the sassy files and some changelog information. All of these files are LGPLv2.1+, so they can be included in Guile. * test-suite/standalone/sassy/tests/: Add the sassy unit tests. * test-suite/standalone/Makefile.am: * test-suite/standalone/test-sassy: Hook the sassy unit tests up to our test suite.
457 lines
14 KiB
Scheme
457 lines
14 KiB
Scheme
; elf.scm - create ELF files from Sassy's output
|
|
; Copyright (C) 2005 Jonathan Kraut
|
|
|
|
; 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 2.1 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 St, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
; Contact:
|
|
; Jonathan Kraut
|
|
; 4130 43 ST #C2
|
|
; Sunnyside, NY 11104
|
|
; jak76@columbia.edu
|
|
|
|
; see file COPYING in the top of Sassy's distribution directory
|
|
|
|
|
|
; module elf
|
|
; import api push-stacks numbers
|
|
; export all
|
|
|
|
(define (sassy-make-elf output-file sassy-output)
|
|
|
|
; the elf constants used
|
|
(define sht-progbits 1)
|
|
(define sht-symtab 2)
|
|
(define sht-strtab 3)
|
|
(define sht-nobits 8)
|
|
(define sht-rel 9)
|
|
(define shf-write 1)
|
|
(define shf-alloc 2)
|
|
(define shf-execinstr 4)
|
|
(define stn-undef 0)
|
|
(define stb-local 0)
|
|
(define stb-global 1)
|
|
(define stt-notype 0)
|
|
(define stt-object 1)
|
|
(define stt-func 2)
|
|
(define stt-section 3)
|
|
(define shn-abs #xfff1)
|
|
(define r-386-32 1)
|
|
(define r-386-pc32 2)
|
|
(define r-386-got32 3)
|
|
(define r-386-plt32 4)
|
|
(define r-386-gotpc 10)
|
|
(define r-386-gotoff 9)
|
|
(define shn-undef 0)
|
|
|
|
; wrappers for symbols that begin with a period, since r5rs doesn't
|
|
; allow you to actually write such symbols literally
|
|
(define dot-text (string->symbol ".text"))
|
|
(define dot-data (string->symbol ".data"))
|
|
(define dot-bss (string->symbol ".bss"))
|
|
(define dot-symtab (string->symbol ".symtab"))
|
|
(define dot-shstrtab (string->symbol ".shstrtab"))
|
|
(define dot-rel-data (string->symbol ".rel.data"))
|
|
(define dot-rel-text (string->symbol ".rel.text"))
|
|
(define dot-strtab (string->symbol ".strtab"))
|
|
|
|
(define empty-symbol (string->symbol ""))
|
|
|
|
(define (symbol<=? x y)
|
|
(string<=? (symbol->string x) (symbol->string y)))
|
|
|
|
; Sort some of the things to ensure identical orders of entries regardless of the particular scheme implementation (hash-table-values)
|
|
(define (quicksort-records lst acc pred)
|
|
(if (or (null? lst) (null? (cdr lst)))
|
|
lst
|
|
(let ((p (car lst)))
|
|
(let iter ((r (cdr lst)) (l '()) (g '()))
|
|
(cond ((null? r) (append (quicksort-records l acc pred)
|
|
(cons p (quicksort-records g acc pred))))
|
|
((pred (acc (car r)) (acc p))
|
|
(iter (cdr r) (cons (car r) l) g))
|
|
(else (iter (cdr r) l (cons (car r) g))))))))
|
|
|
|
; Return a new empty elf string table. Elf string tables consists of
|
|
; \nul, followed by \nul-terminated strings.
|
|
(define (make-string-table)
|
|
(let ((table (make-pushdown-stack)))
|
|
(push-stack-push table 0)
|
|
table))
|
|
|
|
; Enter a symbol in a string-table and return its index
|
|
(define (string-table-set! table symbol)
|
|
(let ((return-ndx (push-stack-size table)))
|
|
(push-stack-push table (map char->integer
|
|
(string->list (symbol->string symbol))))
|
|
(push-stack-push table 0)
|
|
return-ndx))
|
|
|
|
; Entries-tables map symbols or section-names to their row in the
|
|
; appropriate table (sym-table or sh-table) in the image
|
|
(define (make-entries-table) (cons 0 (make-hash-table)))
|
|
|
|
(define (entry-set! entries-table symbol)
|
|
(hash-table-set! (cdr entries-table) symbol (car entries-table))
|
|
(set-car! entries-table (+ (car entries-table) 1)))
|
|
|
|
(define (entry-ref entries-table symbol)
|
|
(hash-table-ref (cdr entries-table) symbol))
|
|
|
|
(define number-of-entries car)
|
|
|
|
(let ((image (make-pushdown-stack))
|
|
(strtab (make-string-table))
|
|
(sh-strtab (make-string-table))
|
|
(e-shoff-patcher #f)
|
|
(e-shnum-patcher #f)
|
|
(e-shstrndx-patcher #f)
|
|
(sh-table (make-pushdown-stack))
|
|
(sh-table-entries (make-entries-table))
|
|
(sym-table (make-pushdown-stack))
|
|
(sym-table-entries (make-entries-table)))
|
|
|
|
|
|
; Add a section header. There should 10 fields: sh-name sh-type
|
|
; sh-flags sh-addr sh-offset sh-size sh-link sh-info sh-addralign and
|
|
; sh-entsize
|
|
(define (section-header-set! name . fields)
|
|
(for-each (lambda (field)
|
|
(push-stack-push sh-table (number->byte-list field 4)))
|
|
fields)
|
|
(entry-set! sh-table-entries name))
|
|
|
|
; Add a symbol
|
|
(define (sym-table-set! name
|
|
strtab-ndx value size info other ndx)
|
|
(for-each (lambda (field)
|
|
(push-stack-push sym-table
|
|
(number->byte-list field 4)))
|
|
(list strtab-ndx value size))
|
|
(for-each (lambda (field)
|
|
(push-stack-push sym-table field))
|
|
(list info other))
|
|
(push-stack-push sym-table (number->byte-list ndx 2))
|
|
(entry-set! sym-table-entries name))
|
|
|
|
; Add a list of symbols
|
|
(define (make-sym-entries sym-lst scope)
|
|
(for-each
|
|
(lambda (symbol)
|
|
(sym-table-set! (sassy-symbol-name symbol)
|
|
(string-table-set! strtab (sassy-symbol-name symbol))
|
|
(or (sassy-symbol-offset symbol) stn-undef)
|
|
(or (sassy-symbol-size symbol) 0)
|
|
(+ (ash scope 4)
|
|
(case (sassy-symbol-section symbol)
|
|
((data) stt-object)
|
|
((text) stt-func)
|
|
(else stt-notype)))
|
|
0
|
|
(case (sassy-symbol-section symbol)
|
|
((heap) (entry-ref sh-table-entries dot-bss))
|
|
((data) (entry-ref sh-table-entries dot-data))
|
|
((text) (entry-ref sh-table-entries dot-text))
|
|
(else shn-undef))))
|
|
sym-lst))
|
|
|
|
; Filter a list of records into two separate lists according to
|
|
; (getter field-val). Return 2 values (lists)
|
|
(define (split-list-of-records list-of-records getter field-val)
|
|
(let iter ((rest list-of-records)
|
|
(win '())
|
|
(lose '()))
|
|
(cond ((null? rest) (values win lose))
|
|
((eq? field-val (getter (car rest)))
|
|
(iter (cdr rest)
|
|
(cons (car rest) win)
|
|
lose))
|
|
(else (iter (cdr rest)
|
|
win
|
|
(cons (car rest) lose))))))
|
|
|
|
; Dispatch on the reloc type and name to push an elf-reloc on to the image
|
|
(define (push-reloc reloc)
|
|
(let ((get-reloc-name
|
|
(lambda (name)
|
|
(case (sassy-symbol-section
|
|
(hash-table-ref (sassy-symbol-table sassy-output)
|
|
name))
|
|
((text) dot-text)
|
|
((data) dot-data)
|
|
((heap) dot-bss)
|
|
(else name))))
|
|
(make-reloc-info
|
|
(lambda (name type)
|
|
(+ (if name
|
|
(ash (entry-ref sym-table-entries name) 8)
|
|
0)
|
|
(case type
|
|
((abs) r-386-32)
|
|
((rel) r-386-pc32)
|
|
((gotpc) r-386-gotpc)
|
|
((gotoff) r-386-gotoff)
|
|
((got32) r-386-got32)
|
|
((plt32) r-386-plt32))))))
|
|
(push-stack-push image (number->byte-list (sassy-reloc-offset reloc) 4))
|
|
(push-stack-push
|
|
image
|
|
(number->byte-list
|
|
(case (sassy-reloc-type reloc)
|
|
((abs)
|
|
(make-reloc-info (if (not (sassy-reloc-name reloc))
|
|
(case (sassy-reloc-section reloc)
|
|
((data) dot-data)
|
|
((text) dot-text))
|
|
; dot-text
|
|
(get-reloc-name (sassy-reloc-name reloc)))
|
|
'abs))
|
|
((rel)
|
|
((sassy-reloc-patcher reloc) -4)
|
|
(make-reloc-info (sassy-reloc-name reloc) 'rel))
|
|
((gotoff) (make-reloc-info (get-reloc-name (sassy-reloc-name reloc))
|
|
'gotoff))
|
|
((gotpc) (make-reloc-info (sassy-reloc-name reloc) 'gotpc))
|
|
((got32) (make-reloc-info (sassy-reloc-name reloc) 'got32))
|
|
((sym32) (make-reloc-info (sassy-reloc-name reloc) 'abs))
|
|
((plt32)
|
|
((sassy-reloc-patcher reloc) -4)
|
|
(make-reloc-info (sassy-reloc-name reloc) 'plt32)))
|
|
4))))
|
|
|
|
; All setup - now to start building:
|
|
|
|
; Create some null entries
|
|
|
|
(section-header-set! empty-symbol 0 0 0 0 0 0 0 0 0 0)
|
|
(sym-table-set! empty-symbol 0 0 0 0 0 0)
|
|
(sym-table-set! 'sh-null 0 0 0 stt-section stb-local shn-abs)
|
|
|
|
; Build elf-header and patchers for later, and pad it.
|
|
|
|
(push-stack-push image (list 127 69 76 70 1 1 1 0 0 0 0 0 0 0 0
|
|
0 1 0 3 0 1 0 0 0 0 0 0 0 0 0 0 0))
|
|
|
|
(set! e-shoff-patcher (push-stack-push->patcher image (list 0 0 0 0)))
|
|
|
|
(push-stack-push image (list 0 0 0 0 52 0 0 0 0 0 40 0))
|
|
|
|
(set! e-shnum-patcher
|
|
(push-stack-push->patcher image (number->byte-list 0 2)))
|
|
|
|
(set! e-shstrndx-patcher
|
|
(push-stack-push->patcher image (number->byte-list 0 2)))
|
|
|
|
(push-stack-align image 16 0)
|
|
|
|
; Handle the heap section
|
|
|
|
(if (not (zero? (sassy-heap-size sassy-output)))
|
|
(begin
|
|
(section-header-set! dot-bss
|
|
(string-table-set! sh-strtab dot-bss)
|
|
sht-nobits
|
|
(+ shf-write shf-alloc)
|
|
0
|
|
(push-stack-size image)
|
|
(sassy-heap-size sassy-output)
|
|
0
|
|
0
|
|
(sassy-heap-align sassy-output)
|
|
0)
|
|
(sym-table-set! dot-bss 0 0 0 stt-section stb-local
|
|
(entry-ref sh-table-entries dot-bss))))
|
|
|
|
; Handle the data section
|
|
|
|
(if (not (zero? (sassy-data-size sassy-output)))
|
|
(begin
|
|
(section-header-set! dot-data
|
|
(string-table-set! sh-strtab dot-data)
|
|
sht-progbits
|
|
(+ shf-write shf-alloc)
|
|
0
|
|
(push-stack-size image)
|
|
(sassy-data-size sassy-output)
|
|
0
|
|
0
|
|
(sassy-data-align sassy-output)
|
|
0)
|
|
(sym-table-set! dot-data 0 0 0 stt-section stb-local
|
|
(entry-ref sh-table-entries dot-data))
|
|
(push-stack-append! image (sassy-data-stack sassy-output))
|
|
(push-stack-align image 16 0)))
|
|
|
|
; Handle the text section
|
|
|
|
(if (not (zero? (sassy-text-size sassy-output)))
|
|
(begin
|
|
(section-header-set! dot-text
|
|
(string-table-set! sh-strtab dot-text)
|
|
sht-progbits
|
|
(+ shf-execinstr shf-alloc)
|
|
0
|
|
(push-stack-size image)
|
|
(sassy-text-size sassy-output)
|
|
0
|
|
0
|
|
(sassy-text-align sassy-output)
|
|
0)
|
|
(sym-table-set! dot-text 0 0 0 stt-section stb-local
|
|
(entry-ref sh-table-entries dot-text))
|
|
(push-stack-append! image (sassy-text-stack sassy-output))
|
|
(push-stack-align image 16 0)))
|
|
|
|
; Handle the symbol table
|
|
|
|
(call-with-values
|
|
(lambda () (split-list-of-records
|
|
(hash-table-values (sassy-symbol-table sassy-output))
|
|
sassy-symbol-scope
|
|
'local))
|
|
(lambda (locals globals)
|
|
(define last-local (number-of-entries sym-table-entries))
|
|
(make-sym-entries (quicksort-records locals sassy-symbol-name symbol<=?)
|
|
stb-local)
|
|
(set! last-local (number-of-entries sym-table-entries))
|
|
(make-sym-entries (quicksort-records globals
|
|
sassy-symbol-name
|
|
symbol<=?)
|
|
stb-global)
|
|
(section-header-set! dot-symtab
|
|
(string-table-set! sh-strtab dot-symtab)
|
|
sht-symtab
|
|
0
|
|
0
|
|
(push-stack-size image)
|
|
(push-stack-size sym-table)
|
|
;strtab up next
|
|
(+ 1 (number-of-entries sh-table-entries))
|
|
last-local
|
|
4
|
|
16)
|
|
(push-stack-append! image sym-table)
|
|
(push-stack-align image 16 0)))
|
|
|
|
; Handle strtab
|
|
|
|
(section-header-set! dot-strtab
|
|
(string-table-set! sh-strtab dot-strtab)
|
|
sht-strtab
|
|
0
|
|
0
|
|
(push-stack-size image)
|
|
(push-stack-size strtab)
|
|
0
|
|
0
|
|
1
|
|
0)
|
|
(push-stack-append! image strtab)
|
|
(push-stack-align image 16 0)
|
|
|
|
; Handle the relocations table
|
|
|
|
(call-with-values
|
|
(lambda () (split-list-of-records (sassy-reloc-list sassy-output)
|
|
sassy-reloc-section
|
|
'data))
|
|
(lambda (datas texts)
|
|
(if (not (null? datas))
|
|
(let ((current-offset (push-stack-size image)))
|
|
(for-each push-reloc (quicksort-records datas sassy-reloc-offset
|
|
<=))
|
|
(section-header-set! dot-rel-data
|
|
(string-table-set! sh-strtab dot-rel-data)
|
|
sht-rel
|
|
0
|
|
0
|
|
current-offset
|
|
(- (push-stack-size image) current-offset)
|
|
(entry-ref sh-table-entries dot-symtab)
|
|
(entry-ref sh-table-entries dot-data)
|
|
4
|
|
8)
|
|
(push-stack-align image 16 0)))
|
|
(if (not (null? texts))
|
|
(let ((current-offset (push-stack-size image)))
|
|
(for-each
|
|
(lambda (reloc)
|
|
; skip 'rel relocs in the text section unless their targets are
|
|
; symbols with an unknown offset (imported, or undefined and exported,
|
|
; like _GLOBAL_OFFSET_TABLE)
|
|
(when (not (and (eq? 'rel (sassy-reloc-type reloc))
|
|
(or (and (sassy-reloc-name reloc)
|
|
(sassy-symbol-offset
|
|
(hash-table-ref (sassy-symbol-table
|
|
sassy-output)
|
|
(sassy-reloc-name
|
|
reloc)
|
|
(lambda () #f))))
|
|
(not (sassy-reloc-name reloc)))))
|
|
(push-reloc reloc)))
|
|
(quicksort-records texts sassy-reloc-offset <=))
|
|
(section-header-set! dot-rel-text
|
|
(string-table-set! sh-strtab dot-rel-text)
|
|
sht-rel
|
|
0
|
|
0
|
|
current-offset
|
|
(- (push-stack-size image) current-offset)
|
|
(entry-ref sh-table-entries dot-symtab)
|
|
(entry-ref sh-table-entries dot-text)
|
|
4
|
|
8)
|
|
(push-stack-align image 16 0)))))
|
|
|
|
; Handle sh-strtab
|
|
|
|
(let ((index (string-table-set! sh-strtab dot-shstrtab)))
|
|
(section-header-set! dot-shstrtab
|
|
index
|
|
sht-strtab
|
|
0
|
|
0
|
|
(push-stack-size image)
|
|
(push-stack-size sh-strtab)
|
|
0
|
|
0
|
|
1
|
|
0)
|
|
(push-stack-append! image sh-strtab)
|
|
(push-stack-align image 16 0))
|
|
|
|
; Patch the elf-header
|
|
|
|
(e-shoff-patcher (number->byte-list (push-stack-size image) 4))
|
|
(e-shnum-patcher (number->byte-list (number-of-entries sh-table-entries) 2))
|
|
(e-shstrndx-patcher (number->byte-list (entry-ref sh-table-entries
|
|
dot-shstrtab)
|
|
2))
|
|
|
|
; Handle the section-header table ...
|
|
|
|
(push-stack-append! image sh-table)
|
|
|
|
; ... and A-WAY-YAY we go!!!!
|
|
|
|
(if (file-exists? output-file)
|
|
(delete-file output-file))
|
|
|
|
(with-output-to-file output-file
|
|
(lambda ()
|
|
(for-each (lambda (byte)
|
|
(write-byte byte))
|
|
(push-stack-items image))))
|
|
|
|
)) ;end sassy-make-elf
|