linker.lisp

   1 ;;;
   2 ;;; Main linker body.
   3 ;;;
   4 ;;; Julian Squires / 2005
   5 ;;;
   6
   7 (in-package :st-linker)
   8
   9 (defstruct module
  10   (name)
  11   (segment-bases)
  12   (segment-sizes)
  13   (symbol-table-size)
  14   (entry-point)
  15   (symbols)
  16   (relocations))
  17
  18 (defun module-segment-base (module segment)
  19   (cdr (assoc segment (module-segment-bases module))))
  20 (defun module-segment-size (module segment)
  21   (cdr (assoc segment (module-segment-sizes module))))
  22 (defun module-segment-relocations (module segment)
  23   (cdr (assoc segment (module-relocations module))))
  24
  25
  26 (defstruct relocation
  27   (address)
  28   (symbol)
  29   (pc-relative-p)
  30   (length)
  31   (extern-p))
  32
  33 (defstruct linker-symbol
  34   (name)
  35   (value)
  36   (type)
  37   ;; global-p, debug-info
  38   (module))
  39
  40 (defvar *global-symbols* nil)
  41 (defvar *current-header-length* nil)
  42
  43
  44
  45 (defun merge-symbols-into-global-table (module global-symbols)
  46   (dovector (sym (module-symbols module))
  47     (setf (linker-symbol-module sym) module)
  48     (sif (gethash (linker-symbol-name sym) global-symbols)
  49          (push sym it)
  50          (setf it (list sym)))))
  51
  52 (defun link (objects &key (out-name "a.out")
  53              (format :gemdos-prg)
  54              (entry-point 0))
  55   "Link the objects specified by the filenames contained in the list
  56 OBJECTS into a binary called OUT-NAME.  The objects are linked
  57 serially by list order."
  58   (setf *global-symbols* (make-hash-table :test #'equal))
  59   (let* ((segment-sizes (list (cons 'text 0)
  60                               (cons 'data 0)
  61                               (cons 'bss 0)))
  62          (modules
  63           (mapcar
  64            (lambda (object)
  65              "Read a module with filename OBJECT, merge symbols into
  66 global symbol table, and update segment sizes."
  67              (let ((module (read-module object)))
  68                (merge-symbols-into-global-table module *global-symbols*)
  69                (dolist (x segment-sizes)
  70                  (incf (cdr x) (module-segment-size module (car x))))
  71                module))
  72            objects)))
  73
  74     (allocate-module-bases modules segment-sizes)
  75
  76     (ecase format
  77       (:gemdos-prg (link-prg modules segment-sizes out-name))
  78       (:binary (link-raw-bin modules segment-sizes out-name entry-point)))))
  79
  80 (defun allocate-module-bases (modules segment-sizes)
  81   (let ((bases (list (cons 'text 0)
  82                      (cons 'data (cdr (assoc 'text segment-sizes)))
  83                      (cons 'bss (+ (cdr (assoc 'data segment-sizes))
  84                                    (cdr (assoc 'text segment-sizes)))))))
  85     (dolist (module modules)
  86       (setf (module-segment-bases module) (copy-alist bases))
  87       (format t "~&relocating ~A at ~A" (module-name module)
  88               (module-segment-bases module))
  89       (dolist (x bases)
  90         (incf (cdr x) (module-segment-size module (car x)))))))
  91
  92
  93 (defun fix-relocation-symbol (reloc module)
  94   (if (relocation-extern-p reloc)
  95       (setf (relocation-symbol reloc) (aref (module-symbols module)
  96                                             (relocation-symbol reloc)))
  97       (setf (relocation-symbol reloc) (nth (relocation-symbol reloc)
  98                                            '(text data bss)))))
  99
 100 (defun fix-relocation-address (reloc module segment)
 101   (incf (relocation-address reloc)
 102         (module-segment-base module segment)))
 103
 104
 105 (defun process-link-time-relocations (stream modules)
 106   "Goes through the relocations for each module, applies whichever
 107 relocations can be done at link time, and then pushes the remainder
 108 onto the fixup list, which it returns, in ascending order of address."
 109   (let ((fixups nil)
 110         (position (file-position stream)))
 111     (dolist (module modules)
 112       (mapcar
 113        (lambda (segment)
 114          (dovector (reloc (module-segment-relocations module segment))
 115            (fix-relocation-symbol reloc module)
 116            (fix-relocation-address reloc module segment)
 117            (awhen
 118                (if (relocation-pc-relative-p reloc)
 119                    (if (relocation-extern-p reloc)
 120                        (relocate-pcrel-extern stream module segment reloc)
 121                        (relocate-pc-relative stream module segment reloc))
 122                    (if (relocation-extern-p reloc)
 123                        (relocate-abs-extern stream module segment reloc)
 124                        (relocate-absolute stream module segment reloc)))
 125              (push it fixups))))
 126        '(text data)))
 127     (file-position stream position)
 128     (sort fixups #'<=)))
 129
 130 (defun file-offset-of-address (address)
 131   (+ address *current-header-length*))
 132
 133
 134 ;;; XXX should use more gensyms in case other things want to be called
 135 ;;; exactly once.
 136 (defmacro patch-stream ((var length stream
 137                          &optional (position (file-position stream)))
 138                         &body body)
 139   (let ((pos-holder (gensym)))
 140     `(let ((,pos-holder ,position))
 141       (file-position ,stream ,pos-holder)
 142       (let ((,var (read-big-endian-data ,stream ,length)))
 143         ,@body
 144         (file-position ,stream ,pos-holder)
 145         (write-big-endian-data ,stream ,var ,length)))))
 146
 147
 148 (defun relocate-absolute (stream module segment reloc)
 149   (declare (ignore segment))
 150   (let ((base (module-segment-base module (relocation-symbol reloc)))
 151         (length (relocation-length reloc)))
 152     (patch-stream (value length stream (file-offset-of-address
 153                                         (relocation-address reloc)))
 154       (incf value base))
 155     ;; adjust address according to length
 156     (when (/= length 32)
 157       (format t "~&short fixup ~A ~A" length (relocation-address reloc))
 158       (decf (relocation-address reloc) (ceiling (- 32 length) 8))))
 159   ;; return fixup
 160   (when (oddp (relocation-address reloc))
 161     (format t "~&probably emitting a bad fixup: ~A ~A ~A"
 162             (relocation-symbol reloc)
 163             (module-name module)
 164             (relocation-address reloc))
 165     (incf (relocation-address reloc)))
 166   (relocation-address reloc))
 167
 168 (defun relocate-abs-extern (stream module segment reloc)
 169   (declare (ignore segment module))
 170   (let ((symbol (find-first-non-extern-instance (relocation-symbol reloc)))
 171         (length (relocation-length reloc)))
 172     (unless symbol
 173       (error "~A is an undefined symbol referenced in ~A."
 174              (linker-symbol-name (relocation-symbol reloc))
 175              (module-name (linker-symbol-module (relocation-symbol reloc)))))
 176     (patch-stream (value length stream (file-offset-of-address
 177                                         (relocation-address reloc)))
 178       (setf value (+ (linker-symbol-value symbol)
 179                      (module-segment-base (linker-symbol-module symbol)
 180                                           (linker-symbol-type symbol)))))
 181     ;; adjust address according to length
 182     (when (/= length 32)
 183       (decf (relocation-address reloc) (ceiling (- 32 length) 8))))
 184   (relocation-address reloc))
 185
 186
 187 (defun find-first-non-extern-instance (symbol)
 188   "Returns the first non-external instance of SYMBOL in the global
 189 symbol table, or NIL."
 190   (let ((sym-list (gethash (linker-symbol-name symbol)
 191                            *global-symbols*)))
 192     (find-if (lambda (x) (not (eq (linker-symbol-type x) 'extern)))
 193              sym-list)))
 194
 195 (defun relocate-pcrel-extern (stream module segment reloc)
 196   (declare (ignore segment module))
 197   (let ((symbol (find-first-non-extern-instance (relocation-symbol reloc)))
 198         (length (relocation-length reloc)))
 199     (patch-stream (value length stream (file-offset-of-address
 200                                         (relocation-address reloc)))
 201       (setf value (- (+ (linker-symbol-value symbol)
 202                         (module-segment-base (linker-symbol-module symbol)
 203                                              (linker-symbol-type symbol)))
 204                      (relocation-address reloc)))
 205       (when (oddp value)
 206         (error "This should have been fixed.")
 207         (decf value))))                 ; fix 24-bit pc-rel problem.
 208   nil)                                  ; no fixup.
 209
 210 (defun relocate-pc-relative (stream module segment reloc)
 211   (declare (ignore segment module stream reloc))
 212   (error "~&pcrel: wish i could say this was being handled.")
 213   nil)