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