mes/module/mes/elf.mes

<;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; elf.mes - produce a i386 elf executable.

;;; Code:

(cond-expand
 (guile)
 (mes
  (mes-use-module (srfi srfi-1))
  (mes-use-module (mes elf-util))))

(define elf32-addr int->bv32)
(define elf32-half int->bv16)
(define elf32-off int->bv32)
(define elf32-word int->bv32)

(define (make-elf functions globals init)
  (define vaddress #x08048000)

  (define ei-magic `(#x7f ,@(string->list "ELF")))
  (define ei-class '(#x01)) ;; 32 bit
  (define ei-data '(#x01))  ;; little endian
  (define ei-version '(#x01))
  (define ei-osabi '(#x00))
  (define ei-pad '(#x0 #x0 #x0 #x0 #x0 #x0 #x0 #x0))
  (define e-ident
    (append
     ei-magic
     ei-class
     ei-data
     ei-version
     ei-osabi
     ei-pad))

  (define ET-EXEC 2)
  (define EM-386 3)
  (define EV-CURRENT 1)

  (define p-filesz (elf32-word 0))
  (define p-memsz (elf32-word 0))
  (define PF-X 1)
  (define PF-W 2)
  (define PF-R 4)
  (define p-flags (elf32-word (logior PF-X PF-W PF-R)))
  (define p-align (elf32-word 1))

  (define (program-header type offset text)
    (append
     (elf32-word type)
     (elf32-off offset)
     (elf32-addr (+ vaddress offset))
     (elf32-addr (+ vaddress offset))
     (elf32-word (length text))
     (elf32-word (length text))
     p-flags
     p-align
     ))

  (define (section-header name type flags offset text sh-link sh-info sh-entsize)
    (append
     (elf32-word name)
     (elf32-word type)
     ;;;;(elf32-word 3) ;; write/alloc must for data hmm
     (elf32-word flags)
     (elf32-addr (+ vaddress offset))
     (elf32-off offset) 
     (elf32-word (length text))
     (elf32-word sh-link)
     (elf32-word sh-info)
     (elf32-word 1)
     (elf32-word sh-entsize)))


  (define e-type (elf32-half ET-EXEC))
  (define e-machine (elf32-half EM-386))
  (define e-version (elf32-word EV-CURRENT))
  (define e-entry (elf32-addr 0))
  ;;(define e-entry (elf32-addr (+ vaddress text-offset)))
  ;;(define e-phoff (elf32-off 0))
  (define e-shoff (elf32-off 0))
  (define e-flags (elf32-word 0))
  ;;(define e-ehsize (elf32-half 0))
  (define e-phentsize (elf32-half (length (program-header 0 0 '()))))
  (define e-phnum (elf32-half 2)) ; text+data
  (define e-shentsize (elf32-half (length (section-header 0 0 0 0 '() 0 0 0))))
  (define e-shnum (elf32-half 7))       ; sections: 7
  (define e-shstrndx (elf32-half 4))

  (define (elf-header size entry sections)
    (append
     e-ident
     e-type
     e-machine
     e-version
     (elf32-addr (+ vaddress entry)) ;; e-entry
     (elf32-off size)                ;; e-phoff
     (elf32-off sections)            ;; e-shoff
     e-flags
     (elf32-half size) ;; e-ehsize
     e-phentsize
     e-phnum
     e-shentsize
     e-shnum
     e-shstrndx
     ))

  (define elf-header-size
    (length (elf-header 0 0 0)))

  (define program-header-size
    (* 2 (length (program-header 0 0 '()))))

  (define text-offset
    (+ elf-header-size program-header-size))

  (define PT-LOAD 1)
  (define (program-headers text data)
    (append
     (program-header PT-LOAD text-offset text)
     (program-header PT-LOAD data-offset data)))

  (define comment
    (string->list
     (string-append
      "MES"
      ;;"Mes -- Maxwell Equations of Software\n"
      ;;"https://gitlab.com/janneke/mes"
      )
     ;; #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x00 #x00
     ;; #\i #\3 #\8 #\6 #x00 #x00 #x00 #x00
     ))

  (define shstr
    `(
      #x00                              ; 0
      ,@(string->list ".text") #x00     ; 1
      ,@(string->list ".data") #x00     ; 7
      ,@(string->list ".comment") #x00     ; 13
      ,@(string->list ".shstrtab") #x00 ; 22
      ,@(string->list ".symtab") #x00  ; 32
      ,@(string->list ".strtab") #x00   ; 40
      ))

  (define (str functions)
    (cons
     0
     (append-map
      (lambda (s) (append (string->list s) (list 0)))
      (map car functions))))

  (define text-length
    (length (functions->text functions globals 0 0 0)))

  (define data-offset
    (+ text-offset text-length))

  (define stt-func 2)
  (define stt-global-func 18)
  (define (symbol-table-entry st-name st-offset st-length st-info st-other st-shndx)
    (append
     (elf32-word st-name)
     (elf32-addr st-offset)
     (elf32-word st-length)
     (list st-info)
     (list st-other)
     (elf32-half st-shndx)))

  (define (sym functions globals)
    (define (symbol->table-entry o)
      (let* ((name (car o))
             (offset (function-offset name functions))
             (len (if (not (cdr o)) 0 (length (text->list (cddr o)))))
             (str (append-map (lambda (x) (cons 0 (string->list x))) (cdr (member name (reverse (map car functions))))))
             (i (1+ (length str))))
        (symbol-table-entry i (+ vaddress text-offset offset) len stt-func 0 1)))
    (append
     (symbol-table-entry 0 0 0 0 0 0)
     (append-map symbol->table-entry functions)))

  (define data-address (+ data-offset vaddress))
  (define text-address (+ text-offset vaddress))

  (define data-length
    (length (globals->data functions globals 0 0)))

  (define comment-length
    (length comment))

  (define comment-offset
    (+ data-offset data-length))

  (define shstr-offset
    (+ comment-offset comment-length))

  (define shstr-length
    (length shstr))

  (define sym-offset
    (+ shstr-offset shstr-length))

  (define SHT-PROGBITS 1)
  (define SHT-SYMTAB 2)
  (define SHT-STRTAB 3)
  (define SHT-NOTE 7)

  (define SHF-WRITE 1)
  (define SHF-ALLOC 2)
  (define SHF-EXEC 4)
  (define SHF-STRINGS #x20)

  (let* ((text (functions->text functions globals text-address 0 data-address))
         (raw-data (globals->data functions globals text-address data-address))
         ;; (data (let loop ((data raw-data) (init init))
         ;;         (if (null? init) data
         ;;             (loop ((car init) functions globals text-address 0 data-address data) (cdr init)))))
         (data raw-data)
         (entry (+ text-offset (function-offset "_start" functions)))
         (sym (sym functions globals))
         (str (str functions)))

    (define (section-headers)
    (append
     (section-header 0 0 0 0 '() 0 0 0)
     (section-header 1 SHT-PROGBITS (logior SHF-ALLOC SHF-EXEC) text-offset text 0 0 0)
     (section-header 7 SHT-PROGBITS (logior SHF-ALLOC SHF-WRITE) data-offset data 0 0 0)
     (section-header 13 SHT-PROGBITS 0 comment-offset comment 0 0 0)
     (section-header 22 SHT-STRTAB 0 shstr-offset shstr 0 0 0)
     (section-header 32 SHT-SYMTAB 0 sym-offset sym 6 0 (length (symbol-table-entry 0 0 0 0 9 0)))
     (section-header 40 SHT-STRTAB 0 str-offset str 0 0 0)))


    (define sym-length
      (length sym))
    
    (define str-offset
      (+ sym-offset sym-length))
    
    (define str-length
      (length str))

    (define section-headers-offset
      (+ str-offset str-length))

    (if (< (length text) 2000)
        (format (current-error-port) "ELF text=~a\n" (map dec->hex text)))
    (if (< (length raw-data) 200)
        (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)))
    (if (< (length data) 200)
        (format (current-error-port) "ELF data=~a\n" (map dec->hex data)))
    (format (current-error-port) "text-offset=~a\n" text-offset)
    (format (current-error-port) "data-offset=~a\n" data-offset)
    (format (current-error-port) "_start=~a\n" (number->string entry 16))
    (append
     (elf-header elf-header-size entry section-headers-offset)
     (program-headers text data)
     text
     data
     comment
     shstr
     sym
     str
     (section-headers))))

(define (logf port string . rest)
  (apply format (cons* port string rest))
  (force-output port)
  #t)

(define (stderr string . rest)
  (apply logf (cons* (current-error-port) string rest)))

(define (write-any x)
  (write-char
   (cond ((char? x) x)
         ((and (number? x) (< (+ x 256) 0))
          (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
         ((number? x) (integer->char (if (>= x 0) x (+ x 256))))
         ((procedure? x)
          (stderr "write-any: proc: ~a\n" x)
          (stderr "  ==> ~a\n" (map dec->hex (x '() '() 0 0)))
          (error "procedure: write-any:" x))
         (else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))

(define (object->elf object)
  (display "dumping elf\n" (current-error-port))
  (for-each
   write-any
   (make-elf (filter cdr (assoc-ref object 'functions)) (assoc-ref object 'globals) (assoc-ref object 'inits))))