From 67c2749fe034f3d734ac8e0084474d009fb91324 Mon Sep 17 00:00:00 2001 From: Julian Squires Date: Fri, 15 Jul 2005 09:54:20 +0100 Subject: [PATCH] Improved to the point where it compiles Michael's verticality demo. Generalized the way that segments are handled all over the place, making it easier to move away from a.out if necessary, and cleaner to boot. Made DC behave approximately as it should, although the new code is ugly and bugly. Fixed unary minus. Made code generation behave much more like devpac by default, which helps a lot with the TOS PRG fixup problem. Fixed a whole bunch of instruction encoding errors. --- README | 13 ++- aout.lisp | 126 +++++++++++++++------------- assembler.lisp | 253 +++++++++++++++++++++++++++++++++++++-------------------- ast.lisp | 7 +- codegen.lisp | 43 ++++++---- machine.lisp | 28 +++---- 6 files changed, 290 insertions(+), 180 deletions(-) diff --git a/README b/README index a23f5e5..28998c0 100644 --- a/README +++ b/README @@ -17,7 +17,6 @@ Literate input. Things to add in the assembler: -Verify that BSS contains only zeros. Checking ranges of types, signed indices, etc. Also, type checking information stored in the symbol table. Output listings (with cycle counts, et cetera). @@ -31,6 +30,8 @@ CL-style macros? (that would be cool!) Debugger info. Output in object formats other than A.OUT. Optimizations/data flow analysis. +Optional lispy object format. (see st-linker README) +ADDI instead of ADD in certain cases. THINGS TO DO BEFORE RELEASE @@ -52,6 +53,11 @@ about them at suitable warning levels. are 8-bit indirect displacements being relocated correctly? verify all possible relocation combinations. - Update dependencies in ASDF file so that it compiles without warnings. +- *last-label* feels like a hack. See if there's an alternative. +- add raw binary output. (also, to linker.) +- DC needs some serious cleanups. +- undo some of the intentional braindamage induced to make us closer + to devpac. @@ -60,15 +66,14 @@ KNOWN ISSUES - macro parameters are broken. At least, style ones are still broken. [assembler] - no checking of vconstraints yet. [codegen] -- DC.B should handle strings properly (right now it will probably only - write out the last byte). [assembler] - Unfinished pseudo-ops: EQUR DCB END IFxx - branch-displacement-bits will behave badly in some unusual situations. -- data segment relocations are unsupported. +- requires that the file end with a newline, and there is no warning + that the last line is ignored. KNOWN MAJOR INCOMPATIBILITIES WITH DEVPAC diff --git a/aout.lisp b/aout.lisp index d0b568b..c7baf9c 100644 --- a/aout.lisp +++ b/aout.lisp @@ -14,66 +14,89 @@ patch header)." :if-exists :new-version :if-does-not-exist :create) ;; revise symbol table/relocs to use numeric indices + (format t "~&~A" *sections*) (let* ((symbols (serialize-symbol-table))) (write-big-endian-data output-stream #x53544F26 32) ; Magic - ;; Text, Data, BSS + ;; section lengths. (mapcar (lambda (x) (write-big-endian-data output-stream (cdr (assoc x section-lengths)) 32)) '(text data bss)) + (mapcar (lambda (x) + (format t "~&~A: ~A - ~A" x (cdr (assoc x section-lengths)) + (section-length (cdr (assoc x *sections*))))) + '(text data bss)) ;; symbol table (write-big-endian-data output-stream (length symbols) 32) ;; entry point (write-big-endian-data output-stream 0 32) - ;; text reloc size - (write-big-endian-data output-stream - (hash-table-count *relocation-table*) - 32) - ;; data reloc size - (write-big-endian-data output-stream - 0 - 32) + ;; reloc sizes + (mapcar (lambda (x) + (write-big-endian-data output-stream + (hash-table-count + (section-relocations + (cdr (assoc x *sections*)))) + 32)) + '(text data)) + + ;; actual contents of sections. + (mapcar (lambda (x) + (copy-stream-contents + (section-object-stream (cdr (assoc x *sections*))) + output-stream)) + '(text data)) - (copy-stream-contents (cdr (assoc 'text *object-streams*)) - output-stream) - (copy-stream-contents (cdr (assoc 'data *object-streams*)) - output-stream) ;; output relocations - (maphash (lambda (k v) - (declare (ignore k)) - ;; address - (write-big-endian-data output-stream - (relocation-address v) - 32) - ;; index|24 pc-rel-p length|2 extern-p spare|4 - (write-big-endian-data - output-stream - (logior (ash (relocation-index-bits v symbols) 8) - (ash (if (relocation-pc-relative-p v) 1 0) 7) - (ash (ceiling (log (relocation-size v) 2)) 5) - (ash (if (relocation-extern-p v) 1 0) 4)) - 32)) - *relocation-table*) - ;; output symbol table - (do ((i 0 (1+ i)) - (sym)) - ((>= i (length symbols))) - (setf sym (aref symbols i)) - (write-big-endian-data output-stream i 32) - (write-big-endian-data - output-stream - (logior (ash (position (asm-symbol-type sym) - '(text data bss absolute extern)) - 25) - (ash (if (asm-symbol-global-p sym) 1 0) 24) - (aout-munge-debug-info (asm-symbol-debug-info sym))) - 32) - (write-big-endian-data output-stream (asm-symbol-value sym) 32)) - ;; output string table - (dotimes (i (length symbols)) - (write-string (asm-symbol-name (aref symbols i)) output-stream) - (write-byte 0 output-stream))))) + (mapcar (lambda (x) + (output-reloc-table output-stream + (section-relocations + (cdr (assoc x *sections*))) + symbols)) + '(text data)) + + (output-symbol-table output-stream symbols) + (output-string-table output-stream symbols)))) + +(defun output-reloc-table (output-stream relocs symbols) + (maphash (lambda (k v) + (declare (ignore k)) + ;; address + (write-big-endian-data output-stream + (relocation-address v) + 32) + ;; index|24 pc-rel-p length|2 extern-p spare|4 + ;; XXX should use dpb to avoid overflows + (write-big-endian-data + output-stream + (logior (ash (relocation-index-bits v symbols) 8) + (ash (if (relocation-pc-relative-p v) 1 0) 7) + (ash (ceiling (log (/ (relocation-size v) 8) 2)) 5) + (ash (if (relocation-extern-p v) 1 0) 4)) + 32)) + relocs)) + +(defun output-symbol-table (output-stream symbols) + ;; output symbol table + (do ((i 0 (1+ i)) + (sym)) + ((>= i (length symbols))) + (setf sym (aref symbols i)) + (write-big-endian-data output-stream i 32) + (write-big-endian-data + output-stream + (logior (ash (position (asm-symbol-type sym) + '(text data bss absolute extern)) + 25) + (ash (if (asm-symbol-global-p sym) 1 0) 24) + (aout-munge-debug-info (asm-symbol-debug-info sym))) + 32) + (write-big-endian-data output-stream (asm-symbol-value sym) 32))) + +(defun output-string-table (output-stream symbols) + (dotimes (i (length symbols)) + (write-string (asm-symbol-name (aref symbols i)) output-stream) + (write-byte 0 output-stream))) ;;; XXX we could do something much more sophisticated, such as having ;;; debug info serve as an index into a debugging info table later in @@ -95,12 +118,3 @@ patch header)." *symbol-table*) table)) -(defun serialize-reloc-table () - (let ((table (make-array (list (hash-table-count *relocation-table*))))) - (with-hash-table-iterator (next *relocation-table*) - (dotimes (i (length table)) - (multiple-value-bind (more-p k v) (next) - (declare (ignore k)) - (assert more-p) - (setf (aref table i) v)))) - table)) diff --git a/assembler.lisp b/assembler.lisp index 6e856b8..dd87110 100644 --- a/assembler.lisp +++ b/assembler.lisp @@ -12,12 +12,12 @@ (eql (caadar operands) 'symbol))) (let ((section (intern (cadar (cdar operands)) (find-package "M68K-ASSEMBLER")))) - (assert (assoc section *object-streams*)) - (setf *current-section* section)))) - ("XDEF" #'define-global) - ("GLOBAL" #'define-global) - ("XREF" #'define-extern) - ("EXTERN" #'define-extern) + (setf *current-section* (cdr (assoc section *sections*))) + (assert *current-section*)))) + ("XDEF" ,#'define-global) + ("GLOBAL" ,#'define-global) + ("XREF" ,#'define-extern) + ("EXTERN" ,#'define-extern) ("ORG" ,(lambda (label op operands modifier) (declare (ignore label op modifier)) (assert (eql (car (first operands)) 'absolute)) @@ -36,7 +36,9 @@ (first operands)) :direction :input :element-type 'unsigned-byte) - (copy-stream-contents stream (current-obj-stream)) + (copy-stream-contents stream + (section-object-stream + *current-section*)) (incf *program-counter* (file-position stream))))) ("ALIGN" ,(lambda (label op operands modifier) @@ -110,8 +112,24 @@ `((,length (absolute-value ,data ,modifier))) length) *backpatch-list*) - (setf data #x4E714E71)) - (output-data data length))))) + (setf data 0)) + ;; The behavior here is that if we're asked to DC + ;; some constant larger than the length we output + ;; it in length chunks. This might be undesired + ;; behavior for some modifiers, although it's + ;; almost certainly desired behavior for bytes. + ;; Maybe some heuristics and warnings should go + ;; here, or at least a flag to enable/disable this + ;; behavior. + (when (minusp data) ; XXX this is totally broken! + (setf data (+ (ash 1 length) data))) + (do ((total (if (<= 0 data 1) 1 (ceiling (log data 2) + length)) + (1- total))) + ((<= total 0)) + (output-data (ldb (byte length (* (1- total) length)) + data) + length)))))) ("DS" ,(lambda (label op operands modifier) (declare (ignore op)) @@ -126,8 +144,8 @@ (output-data 0 (* data length))))) ("DCB") ; constant block -- number,value - ("EQU" #'define-equate) - ("=" #'define-equate) + ("EQU" ,#'define-equate) + ("=" ,#'define-equate) ;; EQUR (register equate) ;; IFEQ etc etc @@ -157,7 +175,7 @@ (unless label (error "~A: EQU always needs a label." *source-position*)) ;; XXX should probably check operands length etc - (add-to-symbol-table label (resolve-expression (first operands)) + (add-to-symbol-table label (absolute-value (first operands)) :type 'absolute)) (defun execute-macro (name operands modifier) @@ -207,7 +225,8 @@ (concatenate 'string *last-label* name) name)) -(defun add-to-symbol-table (sym value &key (type *current-section*) +(defun add-to-symbol-table (sym value + &key (type (section-name *current-section*)) (global-p nil)) (let ((name (extract-sym-name sym))) (setf (gethash name *symbol-table*) @@ -272,7 +291,8 @@ (make-backpatch :template data :length length :program-counter *program-counter* :section *current-section* - :file-position (file-position (current-obj-stream)) + :file-position (file-position + (section-object-stream *current-section*)) :last-label *last-label* :source-position *source-position*)) @@ -280,23 +300,25 @@ `(let ((*program-counter* (backpatch-program-counter ,item)) (*current-section* (backpatch-section ,item)) (*last-label* (backpatch-last-label ,item)) - (*source-position* (backpatch-source-position ,item))) + (*source-position* (backpatch-source-position ,item)) + (*object-stream* (section-object-stream (backpatch-section ,item)))) ,@body)) (defun backpatch () ;; go through backpatch list, try to make all patches (dolist (x *backpatch-list*) - (with-backpatch (x) - (let ((*defining-relocations-p* t)) - (multiple-value-bind (data len) - (generate-code (backpatch-template x) nil nil) - (when (consp data) - (error "~A: Failed to backpatch @ ~A: ~S." - *source-position* *program-counter* data)) - (assert (= len (backpatch-length x))) - (assert (file-position (current-obj-stream) - (backpatch-file-position x))) - (output-data data len)))))) + (using-section ((backpatch-section x)) + (with-backpatch (x) + (let ((*defining-relocations-p* t)) + (multiple-value-bind (data len) + (generate-code (backpatch-template x) nil nil) + (when (consp data) + (error "~A: Failed to backpatch @ ~A: ~S." + *source-position* *program-counter* data)) + (assert (= len (backpatch-length x))) + (assert (file-position (section-object-stream *current-section*) + (backpatch-file-position x))) + (output-data data len))))))) ;;;; RELOCATION @@ -335,20 +357,24 @@ #'relocation-extern-p)))) (defun add-relocation (symbol) - (when *defining-relocations-p* - ;; figure out what kind of relocation this is + (when (and *defining-relocations-p* + (not (eq (get-symbol-type symbol) 'absolute))) (let ((reloc (figure-out-reloc symbol *program-counter*))) (sif (gethash *program-counter* *relocation-table*) (check-reloc-consistency reloc it) (setf it reloc))))) (defun pc-relativise-relocation () - ;; if there's a reloc at this PC, make it pc-relative. - ;; XXX if the symbol is not extern, then delete from relocation - ;; table (no need to relocate relative references within the same - ;; file). + "If there's a relocation at this PC, mark it PC-relative." (swhen (gethash *program-counter* *relocation-table*) - (setf (relocation-pc-relative-p it) t))) + ;; If the symbol is not extern and segment is same as current + ;; section, then delete from relocation table (no need to relocate + ;; same-section relative references within the same file). + (if (or (relocation-extern-p it) + (not (eq (relocation-segment it) + (section-name *current-section*)))) + (setf (relocation-pc-relative-p it) t) + (remhash *program-counter* *relocation-table*)))) (defun fix-relocation-size (size) (swhen (gethash *program-counter* *relocation-table*) @@ -382,7 +408,10 @@ resolved." (t (error "Unknown expression atom: ~A" expression))) (case (car expression) (+ (bin-op '+ #'+)) - (- (bin-op '- #'-)) + (- (if (= (length expression) 2) + (let ((v (resolve-expression (second expression)))) + (if (integerp v) (- v) expression)) + (bin-op '- #'-))) (* (bin-op '* #'*)) (/ (bin-op '/ #'/)) (& (bin-op '& #'logand)) @@ -390,71 +419,114 @@ resolved." (^ (bin-op '^ #'logxor)) (<< (bin-op '<< #'ash)) (>> (bin-op '>> #'(lambda (n count) (ash n (- count))))) - (~ (aif (resolve-expression (second expression)) - (lognot it) - expression)) - (symbol (aif (get-symbol-value expression) - (progn - (add-relocation expression) - it) - expression)) + (~ (let ((v (resolve-expression (second expression)))) + (if (integerp v) + (lognot v) + expression))) + (symbol (acond ((get-symbol-value expression) + (add-relocation expression) + it) + (t expression))) + ;;; XXX if we got a constant, it's a bug. That should have + ;;; been picked out at the AST stage. + (constant (resolve-expression (second expression))) (t expression))))) +;;;; SECTIONS + +(defstruct section + (name) + (object-stream) + (output-fn #'write-big-endian-data) + (relocations (make-hash-table)) + (program-counter 0)) + +(defvar *sections* nil) + +(defun section-length (section) + #+nil + (unless (eq (section-name section) 'bss) + (assert (= (section-program-counter section) + (file-position (section-object-stream section))))) + (section-program-counter section)) + + +(defmacro with-sections (sections &body body) + (if sections + (if (eq (car sections) 'bss) + `(progn + (push (cons ,(car sections) + (make-section :name ,(car sections) + :output-fn #'bss-output-fn + :object-stream nil + :relocations nil)) + *sections*) + (with-sections ,(cdr sections) ,@body)) + + (let ((symbol-of-the-day (gensym))) + `(osicat:with-temporary-file (,symbol-of-the-day + :element-type 'unsigned-byte) + (push (cons ,(car sections) + (make-section :name ,(car sections) + :object-stream ,symbol-of-the-day)) + *sections*) + (with-sections ,(cdr sections) ,@body)))) + + `(progn ,@body))) + + +(defmacro using-section ((section) &body body) + (let ((temporary (gensym))) + `(let* ((,temporary ,section) + (*program-counter* (section-program-counter ,temporary)) + (*relocation-table* (section-relocations ,temporary)) + (*object-stream* (section-object-stream ,temporary))) + (unwind-protect + (progn ,@body) + (setf (section-program-counter ,temporary) *program-counter*))))) + ;;;; "MAIN" STUFF (defvar *source-position*) -(defvar *object-streams*) -(defvar *program-counter*) (defvar *last-label* nil "Last label seen by the assembler. This is used for generating the prefix for local labels.") -(defvar *current-section* 'text "Current section we're assembling +(defvar *current-section* nil "Current section we're assembling in.") -(defmacro with-object-streams (sections &body body) - (if sections - (let ((symbol-of-the-day (gensym))) - `(osicat:with-temporary-file (,symbol-of-the-day - :element-type 'unsigned-byte) - (push (cons ,(car sections) ,symbol-of-the-day) *object-streams*) - (with-object-streams ,(cdr sections) ,@body))) - `(progn ,@body))) +;; Things bound by new section. (also: relocation-table) +(defvar *object-stream*) +(defvar *program-counter*) -(defun current-obj-stream () - (cdr (assoc *current-section* *object-streams*))) (defun assemble (input-name &key (object-name "mr-ed.o")) ;; create symbol table (setf *symbol-table* (make-hash-table :test 'equal) - ;; init program counter - *program-counter* 0 ;; create backpatch list *backpatch-list* nil ;; init macro variables *defining-macro-p* nil *defining-rept-p* nil ;; last label seen *last-label* nil - *current-section* 'text - *object-streams* nil - *relocation-table* (make-hash-table)) + *sections* nil) ;; open file and start processing (with-lexer (input-name) - ;; Note that we create a file for BSS even though it should all be - ;; zeros just for my utterly lazy convenience. It's wasteful, but - ;; I don't feel like putting in all kinds of hideous special cases - ;; just right now. - (with-object-streams ('text 'data 'bss) + (with-sections ('text 'data 'bss) + (setf *current-section* (cdr (assoc 'text *sections*))) (process-current-file) ;; Prior to backpatching, record section lengths, because ;; temporary-files aren't really file streams the way CL would ;; like them to be, so we can't just FILE-LENGTH them. (let ((lengths (mapcar (lambda (x) - (cons (car x) (file-position (cdr x)))) - *object-streams*))) + (cons (car x) + (section-length (cdr x)))) + *sections*))) (backpatch) (finalize-object-file object-name lengths))))) + + (defun process-current-file () (handler-case (loop @@ -465,18 +537,19 @@ in.") (unclutter-line (parse #'next-token)) (assert (eql (pop line) 'line)) - ;; if we're in a macro or repeat, accumulate this line. - (cond (*defining-macro-p* - (if (and (eql (operation-type-of-line line) 'pseudo-op) - (string-equal (opcode-of-line line) "ENDM")) - (process-line line) - (push line *macro-buffer*))) - (*defining-rept-p* - (if (and (eql (operation-type-of-line line) 'pseudo-op) - (string-equal (opcode-of-line line) "ENDR")) - (process-line line) - (push line *macro-buffer*))) - (t (process-line line))))) ; otherwise, process it. + (using-section (*current-section*) + ;; if we're in a macro or repeat, accumulate this line. + (cond (*defining-macro-p* + (if (and (eql (operation-type-of-line line) 'pseudo-op) + (string-equal (opcode-of-line line) "ENDM")) + (process-line line) + (push line *macro-buffer*))) + (*defining-rept-p* + (if (and (eql (operation-type-of-line line) 'pseudo-op) + (string-equal (opcode-of-line line) "ENDR")) + (process-line line) + (push line *macro-buffer*))) + (t (process-line line)))))) (end-of-file nil))) (defun operation-type-of-line (line) @@ -540,13 +613,15 @@ in.") (defun assemble-pseudo-op (label operation operands) (let ((opcode (caadr operation)) (modifier (cadadr operation))) - (acond ((find opcode *asm-pseudo-op-table* - :key #'car :test #'string-equal) - (when (functionp (second it)) - (funcall (second it) label opcode operands modifier))) - ((eql (get-symbol-type opcode) 'macro) - (execute-macro opcode operands modifier)) - (t (error "~&~S: bad pseudo-op ~A!" *source-position* opcode))))) + (let ((*defining-relocations-p* t)) + (acond ((find opcode *asm-pseudo-op-table* + :key #'car :test #'string-equal) + (when (functionp (second it)) + (funcall (second it) label opcode operands modifier))) + ((eql (get-symbol-type opcode) 'macro) + (execute-macro opcode operands modifier)) + (t (error "~&~S: bad pseudo-op ~A!" + *source-position* opcode)))))) (defun output-data (data length) @@ -555,8 +630,12 @@ object file and updates the program counter. Returns the address to which the data assembled." #+nil (unless (zerop (mod length 8)) (setf length (ash (ceiling (/ length 8)) 3))) + (when (eq (section-name *current-section*) 'text) + (unless (zerop (mod length 16)) + (format t "~&~A: ~A" *source-position* length))) (incf *program-counter* (ash length -3)) - (write-big-endian-data (current-obj-stream) data length)) + (funcall (section-output-fn *current-section*) + *object-stream* data length)) ;;;; EOF assembler.lisp diff --git a/ast.lisp b/ast.lisp index d21a018..5417a53 100644 --- a/ast.lisp +++ b/ast.lisp @@ -105,12 +105,15 @@ bitwise-operator unary-operator))) (car (second tree))) +(defun simplify-value (tree) + (second tree)) + (defun simplify-factor (tree) (cond ((= (length tree) 2) - (let ((v (second (second tree)))) + (let ((v (simplify-value (second tree)))) (if (eql (car v) 'constant) (second v) v))) ((= (length tree) 3) (list (simplify-operator (second tree)) - (second (third tree)))) + (simplify-value (third tree)))) ((= (length tree) 4) (simplify-expression (third tree))) (t (error "Strange parse tree.")))) diff --git a/codegen.lisp b/codegen.lisp index f49ca1c..6f2581c 100644 --- a/codegen.lisp +++ b/codegen.lisp @@ -42,23 +42,24 @@ (defun refine-type (operand modifier) (cond ;; XXX: should try to evaluate expression if it exists. - ((and (eql (car operand) 'displacement-indirect) + ((and (eq (car operand) 'displacement-indirect) (zerop (indirect-displacement operand 'word)) (address-register-p (indirect-base-register operand))) 'vanilla-indirect) - ((eql (car operand) 'register) + ((eq (car operand) 'register) (case (char (caadr operand) 0) ((#\d #\D) 'data-register) ((#\a #\A) 'address-register) (t 'register))) ;; XXX: not sure if this is reasonable behavior, but it seems ok ;; to me. - ((eql (car operand) 'absolute) + ((eq (car operand) 'absolute) (case modifier - (word 'absolute-short) (long 'absolute-long) - (t (if (absolute-definitely-needs-long-p operand) - 'absolute-long - 'absolute-short)))) + ;(word 'absolute-short) (long 'absolute-long) + ;; default to absolute long, to avoid some gemdos + ;; relocation-related hassles. probably not the right thing to + ;; do (XXX). + (t 'absolute-long))) (t (car operand)))) (defun operand-type-matches-constraint-type-p (operand constraint modifier) @@ -141,14 +142,15 @@ signalled." (assert (eql (car operand) 'indexed-indirect)) (find 'register (cdr operand) :from-end t :key #'carat)) (defun indirect-displacement (operand modifier) - (let ((length (case modifier (byte 8) (word 16)))) - (cond ((integerp (cadr operand)) (cadr operand)) - ((not (eql (caadr operand) 'expression)) 0) + (let ((length (ecase modifier (byte 8) (word 16)))) + (cond ((= (length operand) 2) 0) (t (prog1 (resolve-expression (cadr operand)) (fix-relocation-size length)))))) -(defun register-mask-list (operand &key flipped-p) - (let ((bitmask (make-array '(16) :element-type 'bit :initial-element 0))) +(defun register-mask-list (operand &optional alterand) + (let ((bitmask (make-array '(16) :element-type 'bit :initial-element 0)) + (flipped-p (and alterand + (eq (car alterand) 'predecrement-indirect)))) ;; iterate over operands (dolist (r (if (eql (car operand) 'register) (list operand) @@ -242,7 +244,8 @@ the length of that data." (defun immediate-value (operand &optional modifier) "Returns a certain number of bits from the immediate value of OPERAND, based on MODIFIER, if specified." - (let ((length (case modifier (byte 8) (word 16) (long 32) (t '?)))) + ;; XXX default length is long? + (let ((length (case modifier ((byte word) 16) (long 32) (t 32)))) (values (prog1 (resolve-expression (second operand)) (fix-relocation-size length)) length))) @@ -268,8 +271,8 @@ displacement is either 8 bits or 16 padded to 24." (let ((value (absolute-value operand (or modifier (if db-p 'word 'byte)))) (length (cond (db-p 16) - ((eql modifier 'word) 24) ;XXX should zero top 8 bits. - (t 8)))) + ((eq modifier 'byte) 8) + (t 24)))) ;; if there's a reloc at this pc, change to pc-relative (pc-relativise-relocation) (fix-relocation-size length) @@ -277,7 +280,11 @@ displacement is either 8 bits or 16 padded to 24." ;; Note PC+2 -- this is due to the way the m68k fetches ;; instructions. XXX (values (or (and (integerp value) - (- value (+ *program-counter* 2))) + (logand + (- value (if (oddp *program-counter*) + (1+ *program-counter*) + *program-counter*)) + #xffff)) value) length))) @@ -310,7 +317,9 @@ displacement is either 8 bits or 16 padded to 24." (unless (integerp length) (setf length val-len) ; for fake-pc (setf (caar item->) val-len)) - (when (integerp val-len) (assert (= (caar item->) val-len))) + ;; XXX shouldn't have to comment this out, but I do due to + ;; silly immediate-value hacks. + ;;(when (integerp val-len) (assert (= (caar item->) val-len))) (if (integerp val) (setf (cadar item->) val) (setf done-p nil))))))) diff --git a/machine.lisp b/machine.lisp index 08c39e0..15aa0d1 100644 --- a/machine.lisp +++ b/machine.lisp @@ -136,20 +136,20 @@ ((4 #b1110) (3 (register-idx first-operand)) (1 ,(if (string= x "L" :start1 (1- (length x))) 1 0)) (2 (modifier-bits modifier)) - (3 ,(cond ((string= x "LS" :end1 2) #b001) - ((string= x "AS" :end1 2) #b000) - ((string= x "ROX" :end1 3) #b010) - (t #b011))) - (3 (register-idx second-operand)))) - (((byte word long) (immediate (<= 1 value 8)) (data-register)) - ((4 #b1110) (3 (immediate-value first-operand)) - (1 ,(if (string= x "L" :start1 (1- (length x))) 1 0)) - (2 (modifier-bits modifier)) (3 ,(cond ((string= x "LS" :end1 2) #b101) ((string= x "AS" :end1 2) #b100) ((string= x "ROX" :end1 3) #b110) (t #b111))) (3 (register-idx second-operand)))) + (((byte word long) (immediate (<= 1 value 8)) (data-register)) + ((4 #b1110) (3 (addq-immediate-value first-operand)) + (1 ,(if (string= x "L" :start1 (1- (length x))) 1 0)) + (2 (modifier-bits modifier)) + (3 ,(cond ((string= x "LS" :end1 2) #b001) + ((string= x "AS" :end1 2) #b000) + ((string= x "ROX" :end1 3) #b010) + (t #b011))) + (3 (register-idx second-operand)))) (((byte word long) (memory-alterable-modes)) ((5 #b11100) (2 ,(cond ((string= x "LS" :end1 2) #b01) @@ -183,7 +183,7 @@ (((byte long) (immediate) (data-alterable-modes)) ((8 #b00001000) (2 ,(cdr x)) (6 (effective-address-mode second-operand modifier)) - (8 #b00000000) (8 (immediate-value immediate 'byte)) + (8 #b00000000) (8 (immediate-value first-operand 'byte)) (? (effective-address-extra second-operand modifier)))))) '(("BCHG" . #b01) ("BCLR" . #b10) ("BSET" . #b11) )) ;; Note that BTST supports PC-relative, while the above three do @@ -197,7 +197,7 @@ (((byte long) (immediate) (data-addressing-modes)) ((10 #b0000100000) (6 (effective-address-mode second-operand modifier)) - (8 #b00000000) (8 (immediate-value immediate 'byte)) + (8 #b00000000) (8 (immediate-value first-operand 'byte)) (? (effective-address-extra second-operand modifier))))) ("CHK" @@ -309,7 +309,7 @@ ("LINK" ((nil (address-register) (immediate)) ((13 #b0100111001010) (3 (register-idx first-operand)) - (16 (immediate-value immediate))))) + (16 (immediate-value second-operand))))) ("MOVE" (((byte word long) (all-ea-modes) (data-alterable-modes)) @@ -347,12 +347,12 @@ (((word long) (register-list) (movem-pre-modes)) ((9 #b010010001) (1 (if-eql-word-p modifier 0 1)) (6 (effective-address-mode second-operand modifier)) - (16 (register-mask-list first-operand :flipped-p t)) + (16 (register-mask-list first-operand second-operand)) (? (effective-address-extra second-operand modifier)))) (((word long) (movem-post-modes) (register-list)) ((9 #b010011001) (1 (if-eql-word-p modifier 0 1)) (6 (effective-address-mode first-operand modifier)) - (16 (register-mask-list second-operand :flipped-p nil)) + (16 (register-mask-list second-operand)) (? (effective-address-extra first-operand modifier))))) ("MOVEP" (((word long) (data-register) (displacement-indirect)) -- 2.11.4.GIT