assembler.lisp

   1
   2 (in-package :m68k-assembler)
   3
   4 ;;;; PSEUDO-OPS
   5
   6 (defparameter *asm-pseudo-op-table*
   7   `(("SECTION" ,(lambda (label op operands modifier)
   8                   (declare (ignore op modifier))
   9                   (handle-label-normally label)
  10                   (assert (and (eql (caar operands) 'absolute)
  11                                (eql (caadar operands) 'symbol)))
  12                   (let ((section (intern (cadar (cdar operands))
  13                                          (find-package "M68K-ASSEMBLER"))))
  14                     (assert (assoc section *object-streams*))
  15                     (setf *current-section* section))))
  16     ("XDEF" #'define-global)
  17     ("GLOBAL" #'define-global)
  18     ("XREF" #'define-extern)
  19     ("EXTERN" #'define-extern)
  20     ("ORG" ,(lambda (label op operands modifier)
  21                (declare (ignore label op modifier))
  22                (assert (eql (car (first operands)) 'absolute))
  23                (setf *program-counter* (absolute-value (first operands)))))
  24
  25     ("INCLUDE"
  26      ,(lambda (label op operands modifier)
  27          (declare (ignore op modifier))
  28          (handle-label-normally label)
  29          (nested-lexing (extract-string-from-operand (first operands)))))
  30     ("INCBIN"
  31      ,(lambda (label op operands modifier)
  32          (declare (ignore op modifier))
  33          (handle-label-normally label)
  34          (with-open-file (stream (extract-string-from-operand
  35                                   (first operands))
  36                                  :direction :input
  37                                  :element-type 'unsigned-byte)
  38            (copy-stream-contents stream (current-obj-stream))
  39            (incf *program-counter* (file-position stream)))))
  40
  41     ("ALIGN" ,(lambda (label op operands modifier)
  42                  (declare (ignore op modifier))
  43                  (handle-label-normally label)
  44                  (let ((align (absolute-value (first operands))))
  45                    (do ()
  46                        ((zerop (mod *program-counter* align)))
  47                      (output-data 0 8)))))
  48     ("EVEN" ,(lambda (label op operands modifier)
  49                 (declare (ignore op modifier operands))
  50                 (handle-label-normally label)
  51                 (unless (evenp *program-counter*)
  52                   (output-data 0 8))))
  53     ;; offset,align -- offset+(PC+align-1)&~(align-1)
  54     ;; XXX untested.
  55     ("CNOP" ,(lambda (label op operands modifier)
  56                  (declare (ignore op modifier))
  57                  (handle-label-normally label)
  58                  (let ((offset (absolute-value (first operands)))
  59                        (align (absolute-value (second operands))))
  60                    (do ()
  61                        ((zerop (mod (- *program-counter* offset) align)))
  62                      (output-data 0 8)))))
  63
  64     ("MACRO"
  65      ,(lambda (label op operands modifier)
  66          (declare (ignore op operands modifier))
  67          ;; if *defining-macro-p* is already set, cry foul.
  68          (assert (not *defining-macro-p*))
  69          (assert label)
  70          ;; otherwise, clear out *macro-buffer*.
  71          (setf *macro-buffer* (list (second label))
  72                *defining-macro-p* t)))
  73     ("ENDM"
  74      ,(lambda (label op operands modifier)
  75          (declare (ignore label op operands modifier))
  76          (assert *defining-macro-p*)
  77          (setf *macro-buffer* (nreverse *macro-buffer*)
  78                *defining-macro-p* nil)
  79          (add-to-symbol-table (first *macro-buffer*)
  80                               (make-asm-macro :body (cdr *macro-buffer*))
  81                               :type 'macro)))
  82
  83     ("REPT"
  84      ,(lambda (label op operands modifier)
  85          (declare (ignore label op modifier))
  86          (assert (not *defining-rept-p*))
  87          (setf *macro-buffer* (list (absolute-value (first operands)))
  88                *defining-rept-p* t)))
  89     ("ENDR"
  90      ,(lambda (label op operands modifier)
  91          (declare (ignore label op operands modifier))
  92          (assert *defining-rept-p*)
  93          (setf *macro-buffer* (nreverse *macro-buffer*)
  94                *defining-rept-p* nil)
  95          (dotimes (i (pop *macro-buffer*))
  96            (dolist (x *macro-buffer*)
  97              (process-line x)))))
  98
  99     ("DC"
 100      ,(lambda (label op operands modifier)
 101          (declare (ignore op))
 102          (handle-label-normally label)
 103          (unless modifier (setf modifier 'word))
 104          (dolist (x operands)
 105            (let ((data (absolute-value x))
 106                  (length (ecase modifier (byte 8) (word 16) (long 32))))
 107              (when (consp data)
 108                (push (make-backpatch-item
 109                       `((,length (absolute-value ,data)))
 110                       length)
 111                      *backpatch-list*)
 112                (setf data #x4E714E71))
 113              (output-data data length)))))
 114     ("DS"
 115      ,(lambda (label op operands modifier)
 116          (declare (ignore op))
 117          (handle-label-normally label)
 118          (unless modifier (setf modifier 'word))
 119          (assert (eql (car (first operands)) 'absolute))
 120          (let ((data (absolute-value (first operands)))
 121                (length (ecase modifier (byte 8) (word 16) (long 32))))
 122            (unless (integerp data)
 123              (error "~A: Need to be able to resolve DS immediately."
 124                     *source-position*))
 125            (output-data 0 (* data length)))))
 126     ("DCB") ; constant block -- number,value
 127
 128     ("EQU" #'define-equate)
 129     ("=" #'define-equate)
 130     ;; EQUR ? (register equate)
 131     ;; IFEQ etc etc
 132
 133     ("END")))
 134
 135 ;;;; MACROS
 136
 137 ;; Devpac macros -- when we see a macro start, collect until the ENDM,
 138 ;; so we can expand ourselves.
 139
 140 (defvar *defining-macro-p* nil)
 141 (defvar *defining-rept-p* nil)
 142 (defvar *macro-buffer*)
 143
 144 (defstruct asm-macro
 145   (count 0)
 146   (body))
 147
 148 (defun define-equate (label op operands modifier)
 149   (declare (ignore op modifier))
 150   (unless label
 151     (error "~A: EQU always needs a label." *source-position*))
 152   ;; XXX should probably check operands length etc
 153   (add-to-symbol-table label (resolve-expression (first operands))
 154                        :type 'absolute))
 155
 156 (defun execute-macro (name operands modifier)
 157   (labels ((sub (match &rest registers)
 158                (declare (ignore registers))
 159                (acase (char match 1)
 160                  (#\@ (format nil "_~D"
 161                               (asm-macro-count (get-symbol-value name))))
 162                  (#\0 (case modifier
 163                         (byte ".B")
 164                         (long ".L")
 165                         ((word t) ".W")))
 166                  (t (nth (digit-to-int it 36) operands))))
 167              (seek+destroy (tree)
 168                (cond ((stringp tree)
 169                       (cl-ppcre:regex-replace-all "\\\\[0-9A-Za-z@]"
 170                                                   tree #'sub
 171                                                   :simple-calls t))
 172                      ((consp tree)
 173                       (let ((new-tree nil))
 174                         (dolist (branch tree)
 175                           (push (seek+destroy branch) new-tree))
 176                         (nreverse new-tree)))
 177                      (t tree))))
 178       (dolist (x (asm-macro-body (get-symbol-value name)))
 179         (process-line (seek+destroy x)))
 180       (incf (asm-macro-count (get-symbol-value name)))))
 181
 182
 183 ;;;; SYMBOL TABLE
 184
 185 (defvar *symbol-table* nil)
 186
 187 (defstruct asm-symbol
 188   (name)
 189   (type)
 190   (value))
 191
 192 (defun maybe-local-label (sym)
 193   (when (and (plusp (length sym)) (eql (char sym 0) #\.))
 194     (concatenate 'string *last-label* sym)))
 195
 196 (defun add-to-symbol-table (sym value &key (type 'relative))
 197   (cond ((consp sym)
 198          (when (eql (first sym) 'label) (setf sym (second sym)))
 199          (assert (eql (first sym) 'symbol))
 200          (when (eql type 'relative)
 201            (aif (maybe-local-label (second sym))
 202                 (setf (second sym) it)
 203                 (setf *last-label* (second sym))))
 204          (setf (gethash (second sym) *symbol-table*)
 205                (list type value *source-position*)))
 206         (t (error "Not sure how to handle this symbol: ~A." sym))))
 207
 208 (defun get-symbol-value (sym)
 209   (when (consp sym)
 210     (when (eql (first sym) 'label) (setf sym (second sym)))
 211     (setf sym (second sym)))
 212   (awhen (or (gethash sym *symbol-table*)
 213              (gethash (maybe-local-label sym) *symbol-table*))
 214     (second it)))
 215
 216 (defun get-symbol-type (sym)
 217   (when (consp sym)
 218     (when (eql (first sym) 'label) (setf sym (second sym)))
 219     (setf sym (second sym)))
 220   (awhen (or (gethash sym *symbol-table*)
 221              (gethash (maybe-local-label sym) *symbol-table*))
 222     (first it)))
 223
 224 (defun asm-symbol-text (sym)
 225   (if (eql (car sym) 'absolute)
 226       (second (second sym))
 227       (second sym)))
 228
 229 (defun define-extern (label op operands modifier))
 230 (defun define-global (label op operands modifier))
 231
 232 ;;;; BACKPATCHING
 233
 234 (defvar *backpatch-list* nil)
 235
 236 ;; backpatch structure
 237 (defstruct backpatch
 238   (template)
 239   (length)
 240   (program-counter)
 241   (section)
 242   (file-position)
 243   (last-label)
 244   (source-position))
 245
 246 (defun make-backpatch-item (data length)
 247   (make-backpatch :template data :length length
 248                   :program-counter *program-counter*
 249                   :section *current-section*
 250                   :file-position (file-position (current-obj-stream))
 251                   :last-label *last-label*
 252                   :source-position *source-position*))
 253
 254 (defmacro with-backpatch ((item) &body body)
 255   `(let ((*program-counter* (backpatch-program-counter ,item))
 256          (*current-section* (backpatch-section ,item))
 257          (*last-label* (backpatch-last-label ,item))
 258          (*source-position* (backpatch-source-position ,item)))
 259     ,@body))
 260
 261 (defun backpatch ()
 262   ;; go through backpatch list, try to make all patches
 263   (dolist (x *backpatch-list*)
 264     (with-backpatch (x)
 265       (multiple-value-bind (data len)
 266           (generate-code (backpatch-template x) nil nil)
 267         (when (consp data)
 268           (error "~A: Failed to backpatch @ ~A: ~S."
 269                  *source-position* *program-counter* data))
 270         (assert (= len (backpatch-length x)))
 271         (assert (file-position (current-obj-stream)
 272                                (backpatch-file-position x)))
 273         (output-data data len)))))
 274
 275
 276 ;;;; RELOCATION
 277
 278 ;; relocation info
 279 (defstruct relocation
 280   (address)
 281   (extern-p)
 282   (pc-relative-p)
 283   (symbol)
 284   (segment))
 285
 286
 287 ;;;; HELPER FUNCTIONS
 288
 289 (defun extract-string-from-operand (operand)
 290   (dolist (x operand)
 291     (cond ((stringp x) (return x))
 292           ((consp x)
 293            (awhen (extract-string-from-operand operand)
 294              (return it))))))
 295
 296 (defun resolve-expression (expression)
 297   "Try and get a numerical value from this expression.  Returns the
 298 further simplified expression, which will be an atom if everything was
 299 resolved."
 300   (flet ((bin-op (sym fn)
 301            (assert (= (length expression) 3))
 302            (let ((a (resolve-expression (second expression)))
 303                  (b (resolve-expression (third expression))))
 304              (if (and (integerp a) (integerp b))
 305                  (funcall fn a b)
 306                  (list sym a b)))))
 307     (if (atom expression)
 308         (cond ((integerp expression) expression)
 309               ((stringp expression) (string->int expression))
 310               (t (error "Unknown expression atom: ~A" expression)))
 311         (case (car expression)
 312           (+ (bin-op '+ #'+))
 313           (- (bin-op '- #'-))
 314           (* (bin-op '* #'*))
 315           (/ (bin-op '/ #'/))
 316           (& (bin-op '& #'logand))
 317           (or (bin-op 'or #'logior))
 318           (^ (bin-op '^ #'logxor))
 319           (<< (bin-op '<< #'ash))
 320           (>> (bin-op '>> #'(lambda (n count) (ash n (- count)))))
 321           (~ (aif (resolve-expression (second expression))
 322                   (lognot it)
 323                   expression))
 324           (symbol (aif (get-symbol-value expression)
 325                        it
 326                        expression))
 327           (t expression)))))
 328
 329
 330 ;;;; "MAIN" STUFF
 331
 332 (defvar *source-position*)
 333 (defvar *object-streams*)
 334 (defvar *program-counter*)
 335 (defvar *last-label* nil "Last label seen by the assembler.  This is
 336 used for generating the prefix for local labels.")
 337 (defvar *current-section* 'text "Current section we're assembling
 338 in.")
 339
 340 (defmacro with-object-streams (sections &body body)
 341   (if sections
 342       (let ((symbol-of-the-day (gensym)))
 343         `(osicat:with-temporary-file (,symbol-of-the-day
 344                                       :element-type 'unsigned-byte)
 345           (push (cons ,(car sections) ,symbol-of-the-day) *object-streams*)
 346           (with-object-streams ,(cdr sections) ,@body)))
 347       `(progn ,@body)))
 348
 349
 350 (defun current-obj-stream ()
 351   (cdr (assoc *current-section* *object-streams*)))
 352
 353 (defun assemble (input-name &key (object-name "mr-ed.o"))
 354   ;; create symbol table
 355   (setf *symbol-table* (make-hash-table :test 'equal)
 356         ;; init program counter
 357         *program-counter* 0
 358         ;; create backpatch list
 359         *backpatch-list* nil
 360         ;; init macro variables
 361         *defining-macro-p* nil *defining-rept-p* nil
 362         ;; last label seen
 363         *last-label* nil
 364         *current-section* 'text
 365         *object-streams* nil)
 366   ;; open file and start processing
 367   (with-lexer (input-name)
 368     ;; Note that we create a file for BSS even though it should all be
 369     ;; zeros just for my utterly lazy convenience.  It's wasteful, but
 370     ;; I don't feel like putting in all kinds of hideous special cases
 371     ;; just right now.
 372     (with-object-streams ('text 'data 'bss)
 373       (process-current-file)
 374       ;; Prior to backpatching, record section lengths, because
 375       ;; temporary-files aren't really file streams the way CL would
 376       ;; like them to be, so we can't just FILE-LENGTH them.
 377       (let ((lengths (mapcar (lambda (x)
 378                                (cons (car x) (file-position (cdr x))))
 379                              *object-streams*)))
 380         (backpatch)
 381         (finalize-object-file object-name lengths)))))
 382
 383
 384 (defun finalize-object-file (name section-lengths)
 385   "Finalize object file (collect sections, write symbol table,
 386 patch header)."
 387   (with-open-file (output-stream name :direction :output
 388                                  :element-type 'unsigned-byte
 389                                  :if-exists :new-version
 390                                  :if-does-not-exist :create)
 391     (write-big-endian-data output-stream #x53544F26 32) ; Magic
 392     ;; Text, Data, BSS
 393     (mapcar (lambda (x)
 394               (write-big-endian-data output-stream (cdr x) 32))
 395             section-lengths)
 396     ;; symbol table
 397     (write-big-endian-data output-stream 0 32)
 398     ;; entry point
 399     (write-big-endian-data output-stream 0 32)
 400     ;; text reloc size
 401     (write-big-endian-data output-stream 0 32)
 402     ;; data reloc size
 403     (write-big-endian-data output-stream 0 32)
 404
 405     (copy-stream-contents (cdr (assoc 'text *object-streams*))
 406                           output-stream)
 407     (copy-stream-contents (cdr (assoc 'data *object-streams*))
 408                           output-stream)
 409     ;; symbol table
 410     ;; relocations
 411     ))
 412
 413
 414 (defun process-current-file ()
 415   (handler-case
 416       (loop
 417        ;; we strip individual token position information here, which
 418        ;; might suck for superfine debugging/warning precision, but
 419        ;; we really don't need all that clutter.
 420        (multiple-value-bind (line *source-position*)
 421            (unclutter-line (parse #'next-token))
 422          (assert (eql (pop line) 'line))
 423
 424          ;; if we're in a macro or repeat, accumulate this line.
 425          (cond (*defining-macro-p*
 426                 (if (and (eql (operation-type-of-line line) 'pseudo-op)
 427                          (string-equal (opcode-of-line line) "ENDM"))
 428                     (process-line line)
 429                     (push line *macro-buffer*)))
 430                (*defining-rept-p*
 431                 (if (and (eql (operation-type-of-line line) 'pseudo-op)
 432                          (string-equal (opcode-of-line line) "ENDR"))
 433                     (process-line line)
 434                     (push line *macro-buffer*)))
 435                (t (process-line line))))) ; otherwise, process it.
 436     (end-of-file nil (format t "~&all done now."))))
 437
 438 (defun operation-type-of-line (line)
 439   (awhen (cadr (find 'operation line :key #'car))
 440     (car it)))
 441
 442 (defun opcode-of-line (line)
 443   (awhen (cadr (find 'operation line :key #'car))
 444     (caadr it)))
 445
 446 (defun process-line (line)
 447   (let ((label (find 'label line :key #'car))
 448         (operation (cadr (find 'operation line :key #'car)))
 449         (operands (mapcar #'simplify-operand
 450                           (extract-operands line))))
 451     (cond ((eql (operation-type-of-line line) 'opcode)
 452            (assemble-opcode label operation operands))
 453           ((eql (operation-type-of-line line) 'pseudo-op)
 454            (assemble-pseudo-op label operation operands))
 455           (t
 456            (when label
 457              ;; might be a macro or something... see if it
 458              ;; exists, first.  and complain about
 459              ;; redefinition, except in the case of locals.
 460              (if (get-symbol-type label)
 461                  (warn "~&~S: tried to redefine ~A (cowardly not allowing this)." *source-position* label)
 462                  (handle-label-normally label)))))))
 463
 464 (defun handle-label-normally (label)
 465   (when (and label (null (get-symbol-type label)))
 466     (add-to-symbol-table (second label) *program-counter*)))
 467
 468 (defun assemble-opcode (label operation operands)
 469   (let ((opcode (caadr operation))
 470         (modifier (cadadr operation)))
 471     (handle-label-normally label)
 472     (awhen (find-matching-entry opcode operands modifier)
 473       (multiple-value-bind (data len)
 474           (generate-code (second it) operands modifier)
 475         (when (consp data)
 476           (push (make-backpatch-item data len) *backpatch-list*)
 477           (setf data #x4E714E71))       ; Output NOP if all else fails.
 478         (output-data data len)))))
 479
 480
 481 (defun assemble-pseudo-op (label operation operands)
 482   (let ((opcode (caadr operation))
 483         (modifier (cadadr operation)))
 484     (acond ((find opcode *asm-pseudo-op-table*
 485                   :key #'car :test #'string-equal)
 486             (when (functionp (second it))
 487               (funcall (second it) label opcode operands modifier)))
 488            ((eql (get-symbol-type opcode) 'macro)
 489             (execute-macro opcode operands modifier))
 490            (t (error "~&~S: bad pseudo-op ~A!" *source-position* opcode)))))
 491
 492
 493 (defun output-data (data length)
 494   "Outputs DATA in big-endian order to the currently active temporary
 495 object file and updates the program counter.  Returns the address to
 496 which the data assembled."
 497   #+nil (unless (zerop (mod length 8))
 498     (setf length (ash (ceiling (/ length 8)) 3)))
 499   (incf *program-counter* (ash length -3))
 500   (write-big-endian-data (current-obj-stream) data length))
 501
 502
 503 ;;;; EOF assembler.lisp