module/language/objcode/elf.scm

   1 ;;; Embedding bytecode in ELF
   2
   3 ;; Copyright (C) 2012 Free Software Foundation, Inc.
   4
   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.
   9 ;;;;
  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.
  14 ;;;;
  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
  18
  19 ;;; Code:
  20
  21 ;; The eval-when is because (language objcode elf) will not be loaded
  22 ;; yet when we go to compile it, but later passes of the
  23 ;; compiler need it.  So we have to be sure that the module is present
  24 ;; at compile time, with all of its definitions.  The easiest way to do
  25 ;; that is just to go ahead and resolve it now.
  26 ;;
  27 (define-module (language objcode elf)
  28   #:use-module (system vm objcode)
  29   #:use-module (system base target)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (ice-9 binary-ports)
  32   #:use-module (system vm elf)
  33   #:export (write-objcode))
  34
  35 (define (bytecode->elf bv)
  36   (let ((string-table (make-elf-string-table)))
  37     (define (intern-string! string)
  38       (call-with-values
  39           (lambda () (elf-string-table-intern string-table string))
  40         (lambda (table idx)
  41           (set! string-table table)
  42           idx)))
  43     (define (make-object name bv relocs . kwargs)
  44       (let ((name-idx (intern-string! (symbol->string name))))
  45         (make-elf-object (apply make-elf-section
  46                                 #:name name-idx
  47                                 #:size (bytevector-length bv)
  48                                 kwargs)
  49                          bv relocs
  50                          (list (make-elf-symbol name 0)))))
  51     (define (make-dynamic-section word-size endianness)
  52       (define (make-dynamic-section/32)
  53         (let ((bv (make-bytevector 24 0)))
  54           (bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
  55           (bytevector-u32-set! bv 4 #x02000000 endianness)
  56           (bytevector-u32-set! bv 8 DT_GUILE_ENTRY endianness)
  57           (bytevector-u32-set! bv 12 0 endianness)
  58           (bytevector-u32-set! bv 16 DT_NULL endianness)
  59           (bytevector-u32-set! bv 20 0 endianness)
  60           (values bv (make-elf-reloc 'abs32/1 12 0 '.rtl-text))))
  61       (define (make-dynamic-section/64)
  62         (let ((bv (make-bytevector 48 0)))
  63           (bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
  64           (bytevector-u64-set! bv 8 #x02000000 endianness)
  65           (bytevector-u64-set! bv 16 DT_GUILE_ENTRY endianness)
  66           (bytevector-u64-set! bv 24 0 endianness)
  67           (bytevector-u64-set! bv 32 DT_NULL endianness)
  68           (bytevector-u64-set! bv 40 0 endianness)
  69           (values bv (make-elf-reloc 'abs64/1 24 0 '.rtl-text))))
  70       (call-with-values (lambda ()
  71                           (case word-size
  72                             ((4) (make-dynamic-section/32))
  73                             ((8) (make-dynamic-section/64))
  74                             (else (error "unexpected word size" word-size))))
  75         (lambda (bv reloc)
  76           (make-object '.dynamic bv (list reloc)
  77                        #:type SHT_DYNAMIC #:flags SHF_ALLOC))))
  78     (define (link-string-table)
  79       (intern-string! ".shstrtab")
  80       (make-object '.shstrtab (link-elf-string-table string-table) '()
  81                    #:type SHT_STRTAB #:flags 0))
  82     (let* ((word-size (target-word-size))
  83            (endianness (target-endianness))
  84            (text (make-object '.rtl-text bv '()))
  85            (dt (make-dynamic-section word-size endianness))
  86            ;; This needs to be linked last, because linking other
  87            ;; sections adds entries to the string table.
  88            (shstrtab (link-string-table)))
  89       (link-elf (list text dt shstrtab)
  90                 #:endianness endianness #:word-size word-size))))
  91
  92 (define (write-objcode objcode port)
  93   (let ((bv (objcode->bytecode objcode (target-endianness))))
  94     (put-bytevector port (bytecode->elf bv))))