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 global
  90             ;; before it was actually defined.  Patch value, debug-info.
  91             ((null (get-symbol-value name))
  92              (let ((sym (get-asm-symbol name)))
  93                (assert (not (eq (asm-symbol-type sym) 'extern))
  94                        (name) "Trying to set a value for an EXTERN symbol!")
  95                (setf (asm-symbol-value sym) *program-counter*
  96                      (asm-symbol-debug-info sym) *source-position*)))
  97             ;; Otherwise, it's a redefinition and I won't stand for it.
  98             (t (warn "~A: tried to redefine label ~A -- ignoring."
  99                      *source-position* name))))))
 100
 101 (defun assemble-opcode (label operation operands)
 102   (let ((opcode (caadr operation))
 103         (modifier (cadadr operation)))
 104     (handle-label-normally label)
 105     (awhen (find-matching-entry opcode operands modifier)
 106       (let ((*defining-relocations-p* t))
 107         (multiple-value-bind (data len)
 108             (generate-code (second it) operands modifier)
 109           (when (consp data)
 110             (push (make-backpatch-item data len) *backpatch-list*)
 111             (setf data #x4E714E71))     ; Output NOP if all else fails.
 112           (output-data data len))))))
 113
 114
 115 (defun assemble-pseudo-op (label operation operands)
 116   (let ((opcode (caadr operation))
 117         (modifier (cadadr operation)))
 118     (let ((*defining-relocations-p* t))
 119       (acond ((get-pseudo-op opcode)
 120               (when (functionp it)
 121                 (funcall it label opcode operands modifier)))
 122              ((eql (get-symbol-type opcode) 'macro)
 123               (execute-macro opcode operands modifier))
 124              (t (error "~&~S: bad pseudo-op ~A!"
 125                        *source-position* opcode))))))
 126
 127
 128 (defun output-data (data length)
 129   "Outputs DATA in big-endian order to the currently active temporary
 130 object file and updates the program counter.  Returns the address to
 131 which the data assembled."
 132   #+nil (unless (zerop (mod length 8))
 133     (setf length (ash (ceiling (/ length 8)) 3)))
 134   (when (eq (section-name *current-section*) 'text)
 135     (unless (zerop (mod length 16))
 136       (format t "~&~A: ~A" *source-position* length)))
 137   (incf *program-counter* (ash length -3))
 138   (funcall (section-output-fn *current-section*)
 139            *object-stream* data length))
 140
 141
 142 ;;;; MACROS
 143
 144 ;; Devpac macros -- when we see a macro start, collect until the ENDM,
 145 ;; so we can expand ourselves.
 146
 147 (defstruct asm-macro
 148   (count 0)
 149   (body))
 150
 151 (defun define-equate (label op operands modifier)
 152   (declare (ignore op modifier))
 153   (unless label
 154     (error "~A: EQU always needs a label." *source-position*))
 155   (assert (= (length operands) 1))
 156   (let ((*defining-relocations-p* nil))
 157     (add-to-symbol-table label (absolute-value (first operands))
 158                          :type 'absolute)))
 159
 160 (defun execute-macro (name operands modifier)
 161   (labels ((sub (match &rest registers)
 162              (declare (ignore registers))
 163              (acase (char match 1)
 164                (#\@ (format nil "_~D"
 165                             (asm-macro-count (get-symbol-value name))))
 166                (#\0 (case modifier (byte ".B") (long ".L") (t ".W")))
 167                (t (nth (digit-to-int it 36) operands))))
 168
 169            (seek+destroy (tree)
 170              (typecase tree
 171                (string
 172                 (cl-ppcre:regex-replace-all "\\\\[0-9A-Za-z@]" tree #'sub
 173                                             :simple-calls t))
 174                (cons (mapcar #'seek+destroy tree))
 175                (t tree))))
 176
 177     (dolist (x (asm-macro-body (get-symbol-value name)))
 178       (process-line (seek+destroy x)))
 179     (incf (asm-macro-count (get-symbol-value name)))))
 180
 181 (defun start-macro (label op operands modifier)
 182   (declare (ignore op operands modifier))
 183   ;; if *defining-macro-p* is already set cry foul.
 184   (assert (not *defining-macro-p*))
 185   (assert label)
 186   ;; otherwise clear out *macro-buffer*.
 187   (setf *macro-buffer* (list (second label))
 188         *defining-macro-p* t))
 189
 190 (defun end-macro (label op operands modifier)
 191   (declare (ignore label op operands modifier))
 192   (assert *defining-macro-p*)
 193   (setf *macro-buffer* (nreverse *macro-buffer*)
 194         *defining-macro-p* nil)
 195   (add-to-symbol-table (first *macro-buffer*)
 196                        (make-asm-macro :body (cdr *macro-buffer*))
 197                        :type 'macro))
 198
 199
 200 ;;;; BACKPATCHING
 201
 202 ;; backpatch structure
 203 (defstruct backpatch
 204   (template)
 205   (length)
 206   (program-counter)
 207   (section)
 208   (file-position)
 209   (last-label)
 210   (source-position))
 211
 212 (defun make-backpatch-item (data length)
 213   (make-backpatch :template data :length length
 214                   :program-counter *program-counter*
 215                   :section *current-section*
 216                   :file-position (file-position
 217                                   (section-object-stream *current-section*))
 218                   :last-label *last-label*
 219                   :source-position *source-position*))
 220
 221 (eval-when (:compile-toplevel :load-toplevel :execute)
 222   (defmacro with-backpatch ((item) &body body)
 223     `(let ((*program-counter* (backpatch-program-counter ,item))
 224            (*current-section* (backpatch-section ,item))
 225            (*last-label* (backpatch-last-label ,item))
 226            (*source-position* (backpatch-source-position ,item))
 227            (*object-stream* (section-object-stream (backpatch-section ,item))))
 228       ,@body)))
 229
 230 (defun backpatch (backpatch-list)
 231   ;; go through backpatch list, try to make all patches
 232   (dolist (x backpatch-list)
 233     (using-section ((backpatch-section x))
 234       (with-backpatch (x)
 235         (let ((*defining-relocations-p* t))
 236           (multiple-value-bind (data len)
 237               (generate-code (backpatch-template x) nil nil)
 238             (when (consp data)
 239               (error "~A: Failed to backpatch @ ~A: ~S."
 240                      *source-position* *program-counter* data))
 241             (assert (= len (backpatch-length x)))
 242             (assert (file-position (section-object-stream *current-section*)
 243                                    (backpatch-file-position x)))
 244             (output-data data len)))))))
 245
 246
 247 ;;;; RELOCATION
 248
 249 ;; relocation info
 250 (defstruct relocation
 251   (address)
 252   (size nil)
 253   (extern-p nil)
 254   (pc-relative-p nil)
 255   ;; only one of symbol or segment can be selected at a time, so the
 256   ;; symbol field provides both functions.
 257   (symbol))
 258
 259 (defun relocation-segment (r) (relocation-symbol r))
 260 (defun (setf relocation-segment) (v r) (setf (relocation-segment r) v))
 261
 262
 263 (defun figure-out-reloc (symbol pc)
 264   (let* ((sym (get-asm-symbol symbol))
 265          (extern-p (eq (asm-symbol-type sym) 'extern)))
 266     (make-relocation :address pc :extern-p extern-p
 267                      :symbol (if extern-p
 268                                  (asm-symbol-name sym)
 269                                  (asm-symbol-type sym)))))
 270
 271 (defun check-reloc-consistency (reloc-a reloc-b)
 272   (assert (every (lambda (fn)
 273                    (eql (funcall fn reloc-a)
 274                         (funcall fn reloc-b)))
 275                  (list #'relocation-address
 276                        ;; XXX relocation-size
 277                        #'relocation-symbol
 278                        #'relocation-extern-p))))
 279
 280 (defun add-relocation (symbol)
 281   (when (and *defining-relocations-p*
 282              (not (eq (get-symbol-type symbol) 'absolute)))
 283     (let ((reloc (figure-out-reloc symbol *program-counter*)))
 284       (sif (gethash *program-counter* *relocation-table*)
 285            (check-reloc-consistency reloc it)
 286            (setf it reloc)))))
 287
 288 (defun pc-relativise-relocation ()
 289   "If there's a relocation at this PC, mark it PC-relative."
 290   (swhen (gethash *program-counter* *relocation-table*)
 291     ;; If the symbol is not extern and segment is same as current
 292     ;; section, then delete from relocation table (no need to relocate
 293     ;; same-section relative references within the same file).
 294     (if (or (relocation-extern-p it)
 295             (not (eq (relocation-segment it)
 296                      (section-name *current-section*))))
 297         (setf (relocation-pc-relative-p it) t)
 298         (remhash *program-counter* *relocation-table*))))
 299
 300 (defun fix-relocation-size (size)
 301   (swhen (gethash *program-counter* *relocation-table*)
 302     (setf (relocation-size it) size)))
 303
 304
 305 ;;;; HELPER FUNCTIONS
 306
 307 (defun extract-string-from-tree (tree)
 308   "Return the first string we come to in TREE."
 309   (tree-find-if #'stringp tree))
 310
 311 (defun resolve-expression (expression)
 312   "Try and get a numerical value from this expression.  Returns the
 313 further simplified expression, which will be an atom if everything was
 314 resolved."
 315   (flet ((bin-op (sym fn)
 316            (assert (= (length expression) 3))
 317            (let ((a (resolve-expression (second expression)))
 318                  (b (resolve-expression (third expression))))
 319              (if (and (integerp a) (integerp b))
 320                  (funcall fn a b)
 321                  (list sym a b)))))
 322     (if (atom expression)
 323         (typecase expression
 324           (integer expression)
 325           (string (string->int expression))
 326           (t (error "Unknown expression atom: ~A" expression)))
 327         (case (car expression)
 328           (+ (bin-op '+ #'+))
 329           (- (if (= (length expression) 2)
 330                  (let ((v (resolve-expression (second expression))))
 331                    (if (integerp v) (- v) expression))
 332                  (bin-op '- #'-)))
 333           (* (bin-op '* #'*))
 334           (/ (bin-op '/ #'/))
 335           (& (bin-op '& #'logand))
 336           (or (bin-op 'or #'logior))
 337           (^ (bin-op '^ #'logxor))
 338           (<< (bin-op '<< #'ash))
 339           (>> (bin-op '>> #'(lambda (n count) (ash n (- count)))))
 340           (~ (let ((v (resolve-expression (second expression))))
 341                (if (integerp v)
 342                    (lognot v)
 343                    expression)))
 344           (symbol (acond ((get-symbol-value expression)
 345                           (add-relocation expression)
 346                           it)
 347                          (t expression)))
 348           ;;; XXX if we got a constant, it's a bug.  That should have
 349           ;;; been picked out at the AST stage.
 350           (constant (resolve-expression (second expression)))
 351           (t expression)))))
 352
 353
 354 ;;;; EOF assembler.lisp