#lang racket/base (provide add-racket-section) (define 32BIT 1) (define 64BIT 2) (define LITTLEEND 1) (define BIGEND 2) (define SECTION-ALIGN 16) ; conservative? (define SHT_PROGBITS 1) (struct elf (ph-offset ph-esize ph-ecount sh-offset sh-esize sh-ecount class format sh-str-index) #:transparent) (struct section (name-offset offset size) #:transparent) (struct program (offset size) #:transparent) (define (copy-port-bytes amt in out) (let ([get (min amt 4096)]) (let ([s (read-bytes get in)]) (unless (and (bytes? s) (= get (bytes-length s))) (error 'add-elf-section "file data copy failed")) (write-bytes s out)) (unless (= get amt) (copy-port-bytes (- amt get) in out)))) (define (write-n-bytes amt out) (let ([put (min amt 4096)]) (write-bytes (make-bytes put 0) out) (unless (= put amt) (write-n-bytes (- amt put) out)))) (define (round-up v align) (let ([d (modulo v align)]) (if (zero? d) v (+ v (- align d))))) (define (read-elf p fail-k k #:dump? [dump? #f]) (define (stop) (raise "unexpected input")) (define (expect b) (eq? b (read-byte p))) (define (skip n) (for ([i (in-range n)]) (when (eof-object? (read-byte p)) (stop)))) (define (read-a-byte) (let ([v (read-byte p)]) (when (eof-object? v) (stop)) v)) (define (skip-half) (skip 2)) (define (skip-word) (skip 4)) (define (show v) (displayln v) v) ;; Read ELF identification --------------- (if (not (and (expect #x7F) (expect (char->integer #\E)) (expect (char->integer #\L)) (expect (char->integer #\F)))) ;; Not an ELF binary (fail-k) ;; Is an ELF binary: (let ([class (read-byte p)]) (unless (or (= class 32BIT) (= class 64BIT)) (stop)) (let ([format (read-byte p)]) (unless (or (= format LITTLEEND) (= format BIGEND)) (stop)) ;; Set up multi-byte reading --------------- (let* ([read-word (lambda () (let ([a (read-a-byte)] [b (read-a-byte)] [c (read-a-byte)] [d (read-a-byte)]) (cond [(= format LITTLEEND) (bitwise-ior a (arithmetic-shift b 8) (arithmetic-shift c 16) (arithmetic-shift d 24))] [else (bitwise-ior d (arithmetic-shift c 8) (arithmetic-shift b 16) (arithmetic-shift a 24))])))] [read-xword (lambda () (if (= class 32BIT) (read-word) (let ([b (read-bytes 8 p)]) (if (and (bytes? b) (= 8 (bytes-length b))) (integer-bytes->integer b #f (= format BIGEND)) (stop)))))] [read-half (lambda () (let ([a (read-a-byte)] [b (read-a-byte)]) (cond [(= format LITTLEEND) (bitwise-ior a (arithmetic-shift b 8))] [else (bitwise-ior b (arithmetic-shift a 8))])))] [skip-addr (lambda () (skip (if (= class 32BIT) 4 8)))] [read-addr (lambda () (read-xword))] [read-off (lambda () (read-xword))]) (skip 1) ; version (skip 9) ; padding (skip-half) ; type (skip-half) ; machine (skip-word) ; version (skip-addr) ; entry ;; Read rest of ELF header ----------------- (let ([ph-offset (read-off)] [sh-offset (read-off)] [flags (read-word)] [eh-size (read-half)] [ph-esize (read-half)] [ph-ecount (read-half)] [sh-esize (read-half)] [sh-ecount (read-half)] [sh-str-index (read-half)]) ;; Read sections ------------------------ (let ([sections (for/list ([i (in-range sh-ecount)]) (file-position p (+ sh-offset (* i sh-esize))) (let ([name-offset (read-word)] [type (read-word)] [flags (read-xword)] [addr (read-addr)] [offset (read-off)] [size (read-xword)] [link (read-word)] [info (read-word)] [align (read-xword)] [esize (read-xword)]) (section name-offset offset size)))]) ;; Read program headers ------------------------ (let ([programs (for/list ([i (in-range ph-ecount)]) (file-position p (+ ph-offset (* i ph-esize))) (let ([type (read-word)] [flags (if (= class 32BIT) 0 (read-word))] [offset (read-off)] [vaddr (read-addr)] [paddr (read-addr)] [file-size (read-xword)]) (program offset file-size)))]) ;; Load strings from string section ------------------------ (let* ([str-section (list-ref sections sh-str-index)] [strs (begin (file-position p (section-offset str-section)) (read-bytes (section-size str-section) p))]) (when dump? (for ([s (in-list sections)]) (printf "~s ~x ~x\n" (regexp-match #rx#"[^\0]*" strs (min (section-name-offset s) (bytes-length strs))) (section-offset s) (section-size s)))) (k (elf ph-offset ph-esize ph-ecount sh-offset sh-esize sh-ecount class format sh-str-index) sections programs str-section strs)))))))))) (define (add-racket-section src-file dest-file section-name get-data) (call-with-input-file* src-file (lambda (in) (read-elf in (lambda () (values #f #f #f)) (lambda (elf sections programs str-section strs) (let ([new-sec-pos (+ (elf-sh-offset elf) (* (elf-sh-esize elf) (elf-sh-ecount elf)))] [new-sec-delta (round-up (elf-sh-ecount elf) SECTION-ALIGN)] [new-str-pos (+ (section-offset str-section) (section-size str-section))] [new-str-delta (round-up (add1 (bytes-length section-name)) SECTION-ALIGN)] [total-size (file-size src-file)] [class (elf-class elf)] [format (elf-format elf)]) (let-values ([(a-pos a-delta b-pos b-delta) (if (new-sec-pos . < . new-str-pos) (values new-sec-pos new-sec-delta new-str-pos new-str-delta) (values new-str-pos new-str-delta new-sec-pos new-sec-delta))] [(data mid) (get-data (+ total-size new-str-delta new-sec-delta))]) (call-with-output-file* dest-file #:exists 'truncate (lambda (out) (let* ([write-word (lambda (v) (if (= format LITTLEEND) (begin (write-byte (bitwise-and v #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -8) #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -16) #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -24) #xFF) out)) (begin (write-byte (bitwise-and (arithmetic-shift v -24) #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -16) #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -8) #xFF) out) (write-byte (bitwise-and v #xFF) out))))] [write-xword (lambda (v) (if (= class 32BIT) (write-word v) (display (integer->integer-bytes v 8 #f (= format BIGEND)) out)))] [write-addr (lambda (v) (write-xword v))] [write-off (lambda (v) (write-xword v))] [write-half (lambda (v) (if (= format LITTLEEND) (begin (write-byte (bitwise-and v #xFF) out) (write-byte (bitwise-and (arithmetic-shift v -8) #xFF) out)) (begin (write-byte (bitwise-and (arithmetic-shift v -8) #xFF) out) (write-byte (bitwise-and v #xFF) out))))] [adjust (lambda (offset) (if (offset . >= . a-pos) (if (offset . >= . b-pos) (+ offset a-delta b-delta) (+ offset a-delta)) offset))] [adjust* (lambda (offset) (add1 (adjust (sub1 offset))))] [at-class (lambda (a b) (if (= class 32BIT) a b))]) (file-position in 0) (copy-port-bytes a-pos in out) (write-n-bytes a-delta out) (copy-port-bytes (- b-pos a-pos) in out) (write-n-bytes b-delta out) (copy-port-bytes (- total-size b-pos) in out) ;; Write new section: (file-position out (adjust* new-sec-pos)) (write-word (section-size str-section)) (write-word SHT_PROGBITS) (write-xword 0) ; flags (write-addr 0) ; addr (write-off (+ total-size new-sec-delta new-str-delta)) (write-xword (bytes-length data)) (write-word 0) ; link (write-word 0) ; info (write-xword 1) ; align (write-xword 0) ; esize ;; Write new string: (file-position out (adjust* new-str-pos)) (write-bytes section-name out) ;; Fix section-header and program-header offsets: (file-position out (at-class 28 32)) (write-off (adjust (elf-ph-offset elf))) (write-off (adjust (elf-sh-offset elf))) ;; Increment section count: (file-position out (at-class 48 60)) (write-half (add1 (length sections))) ;; Increment string section size: (file-position out (adjust (+ (elf-sh-offset elf) (* (elf-sh-str-index elf) (elf-sh-esize elf)) (at-class 20 32)))) (write-xword (+ (section-size str-section) new-str-delta)) ;; Fix up section offsets: (for ([s (in-list sections)] [i (in-naturals)]) (let ([offset (section-offset s)]) (when (offset . > . a-pos) (file-position out (adjust (+ (elf-sh-offset elf) (* i (elf-sh-esize elf)) (at-class 16 24)))) (write-off (adjust offset))))) ;; Fix up program offsets: (for ([p (in-list programs)] [i (in-naturals)]) (let ([offset (program-offset p)]) (when (offset . > . a-pos) (file-position out (adjust (+ (elf-ph-offset elf) (* i (elf-ph-esize elf)) (at-class 4 8)))) (write-off (adjust offset))))) ;; Write new section data: (let ([dest (+ total-size new-sec-delta new-str-delta)]) (file-position out dest) (write-bytes data out) (values dest (+ dest (bytes-length data)) mid))))))))))))