prg.lisp

   1 ;;; Code to support (simple) linking of object files into GEMDOS PRG
   2 ;;; files.  These are basically A.OUT format.
   3
   4 (in-package :st-linker)
   5
   6 (defparameter *aout-obj-header-length* 32) ; bytes
   7 (defparameter *aout-prg-header-length* 28) ; bytes
   8
   9 ;; Object magic is STO^Z
  10 (defun check-magic (stream)
  11   (unless (= (read-big-endian-data stream 32) #x53544F26)
  12     (error "Bad magic.")))
  13
  14
  15 (defstruct module
  16   (name)
  17   (segment-bases)
  18   (segment-sizes)
  19   (symbol-table-size)
  20   (entry-point)
  21   (symbols)
  22   (relocations))
  23
  24 (defun module-segment-base (module segment)
  25   (cdr (assoc segment (module-segment-bases module))))
  26 (defun module-segment-size (module segment)
  27   (cdr (assoc segment (module-segment-sizes module))))
  28 (defun module-segment-relocations (module segment)
  29   (cdr (assoc segment (module-relocations module))))
  30
  31
  32 (defstruct relocation
  33   (address)
  34   (symbol)
  35   (pc-relative-p)
  36   (length)
  37   (extern-p))
  38
  39 (defstruct linker-symbol
  40   (name)
  41   (value)
  42   (type)
  43   ;; global-p, debug-info
  44   (module))
  45
  46
  47 (defun read-relocations (n-relocations stream)
  48   (let ((table (make-array (list n-relocations)
  49                            :element-type 'linker-symbol)))
  50     (dotimes (i n-relocations)
  51       (let ((address (read-big-endian-data stream 32))
  52             (rest (read-big-endian-data stream 32)))
  53         (setf (aref table i)
  54               (make-relocation :address address
  55                                :symbol (ldb (byte 24 8) rest)
  56                                :pc-relative-p (= 1 (ldb (byte 1 7) rest))
  57                                :length (ash 1 (ldb (byte 2 5) rest))
  58                                :extern-p (= 1 (ldb (byte 1 4) rest))))))
  59     table))
  60
  61 (defun read-symbol-table (n-symbols stream module)
  62   (let ((table (make-array (list n-symbols) :element-type 'relocation)))
  63     (dotimes (i n-symbols)
  64       (let ((name-idx (read-big-endian-data stream 32))
  65             (type (read-big-endian-data stream 32))
  66             (value (read-big-endian-data stream 32)))
  67         (setf (aref table i)
  68               (make-linker-symbol :name name-idx
  69                                   :type (ldb (byte 7 25) type)
  70                                   :value value
  71                                   :module module))))
  72     table))
  73
  74 (defun read-string-table (stream symbols)
  75   (dotimes (i (length symbols))
  76     (setf (linker-symbol-name (aref symbols i))
  77           (read-nul-terminated-string stream))))
  78
  79 (defun read-object-header (stream object)
  80   (let ((segment-sizes (mapcar (lambda (x)
  81                                  (cons x (read-big-endian-data stream 32)))
  82                                '(text data bss)))
  83         (symbol-count (read-big-endian-data stream 32))
  84         (entry (read-big-endian-data stream 32))
  85         (reloc-sizes (mapcar (lambda (x)
  86                                (cons x (read-big-endian-data stream 32)))
  87                              '(text data))))
  88     (make-module :name object
  89                  :segment-sizes segment-sizes
  90                  :symbol-table-size symbol-count
  91                  :entry-point entry
  92                  :relocations reloc-sizes)))
  93
  94
  95 (defun read-module (filename)
  96   (with-open-file (stream filename :element-type 'unsigned-byte)
  97     (check-magic stream)
  98     (let ((module (read-object-header stream filename)))
  99       (file-position stream (+ *aout-obj-header-length*
 100                                (module-segment-size module 'text)
 101                                (module-segment-size module 'data)))
 102       (let ((relocs (mapcar
 103                      (lambda (x)
 104                        (cons x
 105                              (read-relocations
 106                               (module-segment-relocations module x)
 107                               stream)))
 108                      '(text data)))
 109             (symbols (read-symbol-table (module-symbol-table-size module)
 110                                         stream filename)))
 111         (read-string-table stream symbols)
 112         (setf (module-relocations module) relocs
 113               (module-symbols module) symbols))
 114       module)))
 115
 116
 117 (defun link-prg (objects &key (out-name "aout.prg"))
 118   (let ((segment-sizes (list (cons 'text 0)
 119                              (cons 'data 0)
 120                              (cons 'bss 0)))
 121         (modules nil))
 122     (dolist (object objects)
 123       (push (read-module object) modules)
 124       ;; XXX merge symbols into global symbol table
 125       (dolist (x segment-sizes)
 126         (incf (cdr x) (module-segment-size (first modules) (car x)))))
 127
 128     (allocate-module-bases modules segment-sizes)
 129
 130     (with-open-file (prg-stream out-name :direction :io
 131                                 :element-type 'unsigned-byte
 132                                 :if-exists :new-version
 133                                 :if-does-not-exist :create)
 134       ;; start writing header
 135       (write-big-endian-data prg-stream #x601a 16)
 136       (mapcar (lambda (x)
 137                 (write-big-endian-data prg-stream
 138                                        (cdr (assoc x segment-sizes))
 139                                        32))
 140               '(text data bss))
 141       (write-big-endian-data prg-stream 0 32) ; no symbol table
 142       (write-big-endian-data prg-stream 0 (* 2 32)) ; reserved, flags
 143       (write-big-endian-data prg-stream 0 16) ; absflag
 144
 145       (dolist (module modules)
 146         ;; over each object, read text segments
 147         (with-open-file (obj-stream (module-name module)
 148                                     :element-type 'unsigned-byte)
 149           (file-position obj-stream *aout-obj-header-length*) ;start of text segment
 150           (copy-from-stream obj-stream prg-stream
 151                             (module-segment-size module 'text))))
 152       (dolist (module modules)
 153         ;; over each object, read data segments
 154         (with-open-file (obj-stream (module-name module)
 155                                     :element-type 'unsigned-byte)
 156           (file-position obj-stream (+ *aout-obj-header-length*
 157                                        (module-segment-size module 'text)))
 158           (copy-from-stream obj-stream prg-stream
 159                             (module-segment-size module 'data))))
 160
 161       (let ((fixups (process-link-time-relocations prg-stream modules)))
 162         (output-load-time-relocations prg-stream fixups)))))
 163
 164
 165 (defun allocate-module-bases (modules segment-sizes)
 166   (let ((bases (list (cons 'text 0)
 167                      (cons 'data #1=(cdr (assoc 'text segment-sizes)))
 168                      (cons 'bss (+ (cdr (assoc 'data segment-sizes))
 169                                    #1#)))))
 170     (dolist (module modules)
 171       (setf (module-segment-bases module) (copy-tree bases))
 172       (format t "~&relocating ~A at ~A" (module-name module)
 173               (module-segment-bases module))
 174       (dolist (x bases)
 175         (incf (cdr x) (module-segment-size module (car x)))))))
 176
 177 (defun process-link-time-relocations (stream modules)
 178   (let ((fixups nil)
 179         (position (file-position stream)))
 180     (dolist (module modules)
 181       (mapcar
 182        (lambda (segment)
 183          (dovector (reloc (module-segment-relocations module segment))
 184            (format t "~&doing reloc ~A" reloc)
 185            (awhen (if (relocation-pc-relative-p reloc)
 186                       (if (relocation-extern-p reloc)
 187                           (relocate-pcrel-extern stream module segment reloc)
 188                           (relocate-pc-relative stream module segment reloc))
 189                       (if (relocation-extern-p reloc)
 190                           (relocate-absolute-extern stream module segment reloc)
 191                           (relocate-absolute stream module segment reloc)))
 192              (push it fixups))))
 193        '(text data)))
 194     (file-position stream position)
 195     (sort fixups #'<=)))
 196
 197 (defun file-offset-of-address (address)
 198   (+ address *aout-prg-header-length*))
 199
 200 (defun relocate-absolute (stream module segment reloc)
 201   (setf (relocation-symbol reloc) (nth (relocation-symbol reloc)
 202                                        '(text data bss)))
 203   (let ((base (module-segment-base module (relocation-symbol reloc))))
 204     ;; add base to value
 205     (incf (relocation-address reloc) (module-segment-base module segment))
 206     (file-position stream
 207                    (file-offset-of-address (relocation-address reloc)))
 208     (let* ((length (* (relocation-length reloc) 8))
 209            (value (read-big-endian-data stream length)))
 210       (file-position stream
 211                      (file-offset-of-address (relocation-address reloc)))
 212       (write-big-endian-data stream (+ value base) length)
 213       ;; adjust address according to length
 214       (when (/= length 32)
 215         (decf (relocation-address reloc) (ceiling (- 32 length) 8))))
 216     ;; return fixup
 217     (relocation-address reloc)))
 218
 219 (defun relocate-absolute-extern (stream module segment reloc)
 220   nil)
 221
 222 (defun relocate-pcrel-extern (stream module segment reloc)
 223   nil)
 224 (defun relocate-pc-relative (stream module segment reloc)
 225   (format t "~&wish i could say this was being handled: ~A ~A ~A"
 226           #1=(module-segment-base module segment)
 227           #2=(module-segment-base module (relocation-symbol reloc))
 228           (- #1# #2#))
 229   nil)
 230
 231 (defun output-load-time-relocations (stream fixups)
 232   (let ((delta (or (and fixups (first fixups)) 0)))
 233     (write-big-endian-data stream delta 32) ;fixup offset
 234     (format t "~&outputting delta of ~A" delta)
 235     ;; output relocations in PC order... make sure relocation is on word
 236     ;; boundry, and fix smaller relocs so that they're long (eg, word
 237     ;; fixups need to start two bytes earlier).  if delta from current
 238     ;; position to next fixup > 254, output byte 1 until < 254.  then
 239     ;; output offset of fixup.
 240     (dolist (addr (cdr fixups))
 241       (assert (= 0 (mod addr 2)))
 242       (format t "~&outputting fixup ~A, delta ~A" addr delta)
 243       (do () ((< (- addr delta) 254))
 244         (write-byte 1 stream)
 245         (incf delta 254))
 246       (write-byte (- addr delta) stream)
 247       (setf delta addr))
 248     (write-byte 0 stream)))             ; no more relocs.
 249
 250
 251 ;;;; UTILITIES
 252
 253 (defmacro dovector ((var vector) &body body)
 254   "Iterate VAR across VECTOR."
 255   `(loop for ,var across ,vector
 256          do (progn ,@body)))
 257
 258 (defun copy-from-stream (source destination length
 259                          &key (element-type 'unsigned-byte))
 260   "Copy LENGTH bytes of data from open stream SOURCE to open stream
 261 DESTINATION."
 262   (let ((buffer (make-array '(4096) :element-type element-type)))
 263     (do ((bytes #1=(read-sequence buffer source) #1#)
 264          (length length (- length bytes)))
 265         ((or (= bytes 0) (<= length 0)))
 266       (write-sequence buffer destination :end (if (> bytes length)
 267                                                   length
 268                                                   bytes)))))
 269
 270 (defun read-big-endian-data (stream length)
 271   "Read LENGTH bits of data encoded big-endian from STREAM, returning
 272 an integer.  LENGTH must be a multiple of 8."
 273   (assert (zerop (logand length 7)))
 274   (do ((pos (- length 8) (- pos 8))
 275        (value (read-byte stream) (logior (read-byte stream)
 276                                          (ash value 8))))
 277       ((<= pos 0) value)))
 278
 279 (defun write-big-endian-data (stream data length)
 280   "Write LENGTH bits of the integer DATA to STREAM, in big-endian
 281 order.  LENGTH must be a multiple of 8."
 282   (assert (zerop (logand length 7)))
 283   (do ((pos (- length 8) (- pos 8)))
 284       ((< pos 0))
 285     (write-byte (ldb (byte 8 pos) data) stream)))
 286
 287
 288 (defun read-nul-terminated-string (stream)
 289   (do ((char (read-byte stream) (read-byte stream))
 290        (string (make-array '(0) :element-type 'character :adjustable t
 291                            :fill-pointer 0)))
 292       ((eql char 0) string)
 293     (vector-push-extend (code-char char) string)))