assembler.lisp

   1
   2 (in-package :m68k-assembler)
   3
   4 ;;;; "MAIN" STUFF
   5
   6 (defun assemble (input-name &key (object-name "mr-ed.o")
   7                  (object-format :aout))
   8   "Assembles a source file named by INPUT-NAME, to an object file
   9 named by OBJECT-NAME.
  10
  11 OBJECT-FORMAT can currently only be :AOUT for relocatable a.out object
  12 files."
  13   (wipe-symbol-table)
  14   (setf ;; create backpatch list
  15         *backpatch-list* nil
  16         ;; init macro variables
  17         *defining-macro-p* nil *defining-rept-p* nil
  18         ;; last label seen
  19         *last-label* nil
  20         *sections* nil)
  21   ;; open file and start processing
  22   (with-lexer (input-name)
  23     (with-sections ('text 'data 'bss)
  24       (setf *current-section* (cdr (assoc 'text *sections*)))
  25       (process-current-file)
  26       ;; Prior to backpatching, record section lengths, because
  27       ;; temporary-files aren't really file streams the way CL would
  28       ;; like them to be, so we can't just FILE-LENGTH them.
  29       (let ((lengths (mapcar (lambda (x)
  30                                (cons (car x)
  31                                      (section-length (cdr x))))
  32                              *sections*)))
  33         (backpatch *backpatch-list*)
  34         (ecase object-format
  35           (:aout (finalize-object-file object-name lengths)))))))
  36
  37
  38
  39 (defun process-current-file ()
  40   (handler-case
  41       (loop
  42        ;; we strip individual token position information here, which
  43        ;; might suck for superfine debugging/warning precision, but
  44        ;; we really don't need all that clutter.
  45        (multiple-value-bind (line *source-position*)
  46            (unclutter-line (parse #'next-token))
  47          (assert (eq (pop line) 'line) ()
  48                  "Some internal parse tree is messed up.")
  49
  50          (using-section (*current-section*)
  51            ;; if we're in a macro or repeat, just accumulate this
  52            ;; line.  otherwise, process it.
  53            (cond ((or *defining-macro-p* *defining-rept-p*)
  54                   (if (and (eq (operation-type-of-line line) 'pseudo-op)
  55                            (string-equal (opcode-of-line line)
  56                                          (if *defining-macro-p*
  57                                              "ENDM" "ENDR")))
  58                       (process-line line)
  59                       (push line *macro-buffer*)))
  60                  (t (process-line line))))))
  61     (end-of-file nil)))
  62
  63 (defun operation-type-of-line (line)
  64   (awhen (cadr (find 'operation line :key #'car)) (car it)))
  65
  66 (defun opcode-of-line (line)
  67   (awhen (cadr (find 'operation line :key #'car)) (caadr it)))
  68
  69 (defun process-line (line)
  70   (let ((label (find 'label line :key #'car))
  71         (operation (cadr (find 'operation line :key #'car)))
  72         (operands (mapcar #'simplify-operand
  73                           (extract-operands line))))
  74     (cond ((eq (operation-type-of-line line) 'opcode)
  75            (assemble-opcode label operation operands))
  76           ((eq (operation-type-of-line line) 'pseudo-op)
  77            (assemble-pseudo-op label operation operands))
  78           (t
  79            (handle-label-normally label)))))
  80
  81 (defun handle-label-normally (label)
  82   (when label
  83     (let ((name (extract-string-from-tree label)))
  84       (when (not (local-label-name-p name))
  85         (setf *last-label* name))
  86       ;; If the type is nil, the symbol isn't present.
  87       (cond ((null (get-symbol-type name))
  88              (add-to-symbol-table name *program-counter*))
  89             ;; If the value is nil, it was probably declared as a
  90             ;; global before it was actually defined.  Patch value,
  91             ;; type, debug-info.
  92             ((null (get-symbol-value name))
  93              (let ((sym (get-asm-symbol name)))
  94                (assert (not (eq (asm-symbol-type sym) 'extern))
  95                        (name) "Trying to set a value for an EXTERN symbol!")
  96                (setf (asm-symbol-value sym) *program-counter*
  97                      (asm-symbol-type sym) (section-name *current-section*)
  98                      (asm-symbol-debug-info sym) *source-position*)))
  99             ;; Otherwise, it's a redefinition and I won't stand for it.
 100             (t (warn "~A: tried to redefine label ~A -- ignoring."
 101                      *source-position* name))))))
 102
 103 (defun assemble-opcode (label operation operands)
 104   (let ((opcode (caadr operation))
 105         (modifier (cadadr operation)))
 106     (handle-label-normally label)
 107     (aif (find-matching-entry opcode operands modifier)
 108          (let ((*defining-relocations-p* t))
 109            (multiple-value-bind (data len)
 110                (generate-code (second it) operands modifier)
 111              (when (consp data)
 112                (push (make-backpatch-item data len) *backpatch-list*)
 113                (setf data #x4E714E71))  ; Output NOP if all else fails.
 114              (output-data data len)))
 115          (error "~S: no matching opcode for ~A!" *source-position*
 116                 opcode))))
 117
 118
 119 (defun assemble-pseudo-op (label operation operands)
 120   (let ((opcode (caadr operation))
 121         (modifier (cadadr operation)))
 122     (let ((*defining-relocations-p* t))
 123       (acond ((get-pseudo-op opcode)
 124               (when (functionp it)
 125                 (funcall it label opcode operands modifier)))
 126              ((eql (get-symbol-type opcode) 'macro)
 127               (execute-macro opcode operands modifier))
 128              (t (error "~&~S: bad pseudo-op ~A!"
 129                        *source-position* opcode))))))
 130
 131
 132 (defun output-data (data length)
 133   "Outputs DATA in big-endian order to the currently active temporary
 134 object file and updates the program counter.  Returns the address to
 135 which the data assembled."
 136   #+nil (unless (zerop (mod length 8))
 137     (setf length (ash (ceiling (/ length 8)) 3)))
 138   (when (eq (section-name *current-section*) 'text)
 139     (unless (zerop (mod length 16))
 140       (format t "~&~A: ~A" *source-position* length)))
 141   (incf *program-counter* (ash length -3))
 142   (funcall (section-output-fn *current-section*)
 143            *object-stream* data length))
 144
 145
 146 ;;;; MACROS
 147
 148 ;; Devpac macros -- when we see a macro start, collect until the ENDM,
 149 ;; so we can expand ourselves.
 150
 151 (defstruct asm-macro
 152   (count 0)
 153   (body))
 154
 155 (defun define-equate (label op operands modifier)
 156   (declare (ignore op modifier))
 157   (unless label
 158     (error "~A: EQU always needs a label." *source-position*))
 159   (assert (= (length operands) 1))
 160   (let ((*defining-relocations-p* nil))
 161     (add-to-symbol-table label (absolute-value (first operands))
 162                          :type 'absolute)))
 163
 164 (defun execute-macro (name operands modifier)
 165   (labels ((sub (match &rest registers)
 166              (declare (ignore registers))
 167              (acase (char match 1)
 168                (#\@ (format nil "_~D"
 169                             (asm-macro-count (get-symbol-value name))))
 170                (#\0 (case modifier (byte ".B") (long ".L") (t ".W")))
 171                ;; XXX ugly hack.
 172                (t (extract-string-from-tree (nth (1- (digit-to-int it 36))
 173                                                  operands)))))
 174
 175            (seek+destroy (tree)
 176              (typecase tree
 177                (string
 178                 (cl-ppcre:regex-replace-all "\\\\[0-9A-Za-z@]" tree #'sub
 179                                             :simple-calls t))
 180                (cons (mapcar #'seek+destroy tree))
 181                (t tree))))
 182
 183     (dolist (x (asm-macro-body (get-symbol-value name)))
 184       (process-line (seek+destroy x)))
 185     (incf (asm-macro-count (get-symbol-value name)))))
 186
 187 (defun start-macro (label op operands modifier)
 188   (declare (ignore op operands modifier))
 189   ;; if *defining-macro-p* is already set cry foul.
 190   (assert (not *defining-macro-p*))
 191   (assert label)
 192   ;; otherwise clear out *macro-buffer*.
 193   (setf *macro-buffer* (list (second label))
 194         *defining-macro-p* t))
 195
 196 (defun end-macro (label op operands modifier)
 197   (declare (ignore label op operands modifier))
 198   (assert *defining-macro-p*)
 199   (setf *macro-buffer* (nreverse *macro-buffer*)
 200         *defining-macro-p* nil)
 201   (add-to-symbol-table (first *macro-buffer*)
 202                        (make-asm-macro :body (cdr *macro-buffer*))
 203                        :type 'macro))
 204
 205
 206 ;;;; BACKPATCHING
 207
 208 ;; backpatch structure
 209 (defstruct backpatch
 210   (template)
 211   (length)
 212   (program-counter)
 213   (section)
 214   (file-position)
 215   (last-label)
 216   (source-position))
 217
 218 (defun make-backpatch-item (data length)
 219   (make-backpatch :template data :length length
 220                   :program-counter *program-counter*
 221                   :section *current-section*
 222                   :file-position (file-position
 223                                   (section-object-stream *current-section*))
 224                   :last-label *last-label*
 225                   :source-position *source-position*))
 226
 227 (eval-when (:compile-toplevel :load-toplevel :execute)
 228   (defmacro with-backpatch ((item) &body body)
 229     `(let ((*program-counter* (backpatch-program-counter ,item))
 230            (*current-section* (backpatch-section ,item))
 231            (*last-label* (backpatch-last-label ,item))
 232            (*source-position* (backpatch-source-position ,item))
 233            (*object-stream* (section-object-stream (backpatch-section ,item))))
 234       ,@body)))
 235
 236 (defun backpatch (backpatch-list)
 237   ;; go through backpatch list, try to make all patches
 238   (dolist (x backpatch-list)
 239     (using-section ((backpatch-section x))
 240       (with-backpatch (x)
 241         (let ((*defining-relocations-p* t))
 242           (multiple-value-bind (data len)
 243               (generate-code (backpatch-template x) nil nil)
 244             (when (consp data)
 245               (error "~A: Failed to backpatch @ ~A: ~S."
 246                      *source-position* *program-counter* data))
 247             (assert (= len (backpatch-length x)))
 248             (assert (file-position (section-object-stream *current-section*)
 249                                    (backpatch-file-position x)))
 250             (output-data data len)))))))
 251
 252
 253 ;;;; RELOCATION
 254
 255 ;; relocation info
 256 (defstruct relocation
 257   (address)
 258   (size nil)
 259   (extern-p nil)
 260   (pc-relative-p nil)
 261   ;; only one of symbol or segment can be selected at a time, so the
 262   ;; symbol field provides both functions.
 263   (symbol))
 264
 265 (defun relocation-segment (r) (relocation-symbol r))
 266 (defun (setf relocation-segment) (v r) (setf (relocation-segment r) v))
 267
 268
 269 (defun figure-out-reloc (symbol pc)
 270   (let* ((sym (get-asm-symbol symbol))
 271          (extern-p (eq (asm-symbol-type sym) 'extern)))
 272     (make-relocation :address pc :extern-p extern-p
 273                      :symbol (if extern-p
 274                                  (asm-symbol-name sym)
 275                                  (asm-symbol-type sym)))))
 276
 277 (defun check-reloc-consistency (reloc-a reloc-b)
 278   (assert (every (lambda (fn)
 279                    (eql (funcall fn reloc-a)
 280                         (funcall fn reloc-b)))
 281                  (list #'relocation-address
 282                        ;; XXX relocation-size
 283                        #'relocation-symbol
 284                        #'relocation-extern-p))))
 285
 286 (defun add-relocation (symbol)
 287   (when (and *defining-relocations-p*
 288              (not (eq (get-symbol-type symbol) 'absolute)))
 289     (let ((reloc (figure-out-reloc symbol *program-counter*)))
 290       (sif (gethash *program-counter* *relocation-table*)
 291            (check-reloc-consistency reloc it)
 292            (setf it reloc)))))
 293
 294 (defun pc-relativise-relocation ()
 295   "If there's a relocation at this PC, mark it PC-relative."
 296   (swhen (gethash *program-counter* *relocation-table*)
 297     ;; If the symbol is not extern and segment is same as current
 298     ;; section, then delete from relocation table (no need to relocate
 299     ;; same-section relative references within the same file).
 300     (if (or (relocation-extern-p it)
 301             (not (eq (relocation-segment it)
 302                      (section-name *current-section*))))
 303         (setf (relocation-pc-relative-p it) t)
 304         (remhash *program-counter* *relocation-table*))))
 305
 306 (defun fix-relocation-size (size)
 307   (swhen (gethash *program-counter* *relocation-table*)
 308     (setf (relocation-size it) size)))
 309
 310
 311 ;;;; HELPER FUNCTIONS
 312
 313 (defun extract-string-from-tree (tree)
 314   "Return the first string we come to in TREE."
 315   (tree-find-if #'stringp tree))
 316
 317 (defun resolve-expression (expression)
 318   "Try and get a numerical value from this expression.  Returns the
 319 further simplified expression, which will be an atom if everything was
 320 resolved."
 321   (flet ((bin-op (sym fn)
 322            (assert (= (length expression) 3))
 323            (let ((a (resolve-expression (second expression)))
 324                  (b (resolve-expression (third expression))))
 325              (if (and (integerp a) (integerp b))
 326                  (funcall fn a b)
 327                  (list sym a b)))))
 328     (if (atom expression)
 329         (typecase expression
 330           (integer expression)
 331           (string (string->int expression))
 332           (t (error "Unknown expression atom: ~A" expression)))
 333         (case (car expression)
 334           (+ (bin-op '+ #'+))
 335           (- (if (= (length expression) 2)
 336                  (let ((v (resolve-expression (second expression))))
 337                    (if (integerp v) (- v) expression))
 338                  (bin-op '- #'-)))
 339           (* (bin-op '* #'*))
 340           (/ (bin-op '/ #'/))
 341           (& (bin-op '& #'logand))
 342           (or (bin-op 'or #'logior))
 343           (^ (bin-op '^ #'logxor))
 344           (<< (bin-op '<< #'ash))
 345           (>> (bin-op '>> #'(lambda (n count) (ash n (- count)))))
 346           (~ (let ((v (resolve-expression (second expression))))
 347                (if (integerp v)
 348                    (lognot v)
 349                    expression)))
 350           (symbol (acond ((get-symbol-value expression)
 351                           (add-relocation expression)
 352                           it)
 353                          (t expression)))
 354           ;;; XXX if we got a constant, it's a bug.  That should have
 355           ;;; been picked out at the AST stage.
 356           (constant (resolve-expression (second expression)))
 357           (t expression)))))
 358
 359
 360 ;;;; EOF assembler.lisp