John Lorentzson
c41fb46457
Storing assembly instructions in a list felt nice since that lets me just fire and forget, but if we want to properly optimize short branches (i.e. branches that do not require a full JMP) we'll need to be able to rewrite assembly after linking, and I feel that's best done by making assembly instructions hold a NEXT rather than poking at a list clumsily. The first linking pass was also moved out to a separate function since we may want to run the first pass twice, first after the initial assembling and second after expanding optimistic short branches (those that turned out to be longer branches than 127/128 bytes) into a long branch snippet (branch with inverted condition skipping over a JMP).
198 lines
7.7 KiB
Common Lisp
198 lines
7.7 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defclass asm-object ()
|
|
((%source :accessor source :initarg :source :initform nil)
|
|
(%next :accessor next :initform nil)))
|
|
|
|
(defclass asm-label (asm-object)
|
|
((%name :accessor name :initarg :name)
|
|
(%address :accessor address :initform nil)))
|
|
|
|
(defclass asm-instruction (asm-object)
|
|
((%opcode :accessor opcode :initarg :opcode)
|
|
(%operand :accessor operand :initarg :operand :initform nil)
|
|
(%byte-length :accessor byte-length :initarg :byte-length)))
|
|
|
|
(defvar *asm-labels* (make-hash-table :test #'equal)
|
|
"A hash table connecting identities (names) to ASM-LABEL objects.")
|
|
|
|
(defvar *asm-head* nil
|
|
"The first assembly object, used for traversal.")
|
|
(defvar *asm-foot* nil
|
|
"The (so far) last assembly object, used for construction.")
|
|
|
|
(defun emit-asm-object (obj)
|
|
(if (null *asm-foot*)
|
|
(setf *asm-head* obj)
|
|
(setf (next *asm-foot*) obj))
|
|
(setf *asm-foot* obj))
|
|
|
|
(defun emit-asm-instruction (&rest initargs)
|
|
(let ((new-instruction (apply #'make-instance
|
|
'asm-instruction
|
|
initargs)))
|
|
(emit-asm-object new-instruction)))
|
|
|
|
(defun emit-asm-label (identity)
|
|
(let ((label (make-instance 'asm-label :name identity)))
|
|
(setf (gethash identity *asm-labels*)
|
|
label)
|
|
(emit-asm-object label)))
|
|
|
|
(defvar *variable-allocations* (make-hash-table))
|
|
(defvar *last-instruction* '(:nop))
|
|
|
|
(defun varvec-index-in-zeropage-p (index)
|
|
;; TODO: Handle case of too many variables
|
|
t)
|
|
|
|
(defun argvec-index-in-zeropage-p (index)
|
|
;; TODO: Handle case of too many arguments (? not realistically needed)
|
|
t)
|
|
|
|
(defparameter +argvec-offset+ #x00)
|
|
(defparameter +varvec-offset+ #x08)
|
|
|
|
(defmacro with-variable-allocations (allocations &body body)
|
|
`(let ((*variable-allocations* (make-hash-table)))
|
|
(loop :for alloc :in ,allocations
|
|
:do (setf (gethash (data alloc) *variable-allocations*) alloc))
|
|
,@body))
|
|
|
|
(defun allocation-details (data)
|
|
(gethash data *variable-allocations*))
|
|
|
|
(defun data-reference (data)
|
|
(ecase (strategy (allocation-details data))
|
|
((:named-variable :temporary-variable)
|
|
(+ (varvec-index (allocation-details data))
|
|
+varvec-offset+))
|
|
(:direct-to-argvec
|
|
(+ (position data (inputs (user data)))
|
|
+argvec-offset+))))
|
|
|
|
(defmacro define-normal-emitter (name immediate-opcode zeropage-opcode absolute-opcode)
|
|
`(defun ,name (mode value)
|
|
(cond ((eql mode :immediate)
|
|
(emit-asm-instruction :opcode ,immediate-opcode
|
|
:operand (the (unsigned-byte 8) value)
|
|
:byte-length 2))
|
|
((and (eql mode :address)
|
|
(< value #x100))
|
|
(emit-asm-instruction :opcode ,zeropage-opcode
|
|
:operand (the (unsigned-byte 8) value)
|
|
:byte-length 2))
|
|
((eql mode :address)
|
|
(emit-asm-instruction :opcode ,absolute-opcode
|
|
:operand (the (unsigned-byte 16) value)
|
|
:byte-length 3))
|
|
(t
|
|
(error "Invalid usage of ~A with arguments (~A ~A)" ',name mode value)))))
|
|
|
|
(define-normal-emitter emit-lda #xa9 #xa5 #xad)
|
|
(define-normal-emitter emit-sta (error "STA has no immediate mode.") #x85 #x8d)
|
|
(define-normal-emitter emit-adc #x69 #x65 #x6d)
|
|
|
|
(defun emit-store-result (result)
|
|
(if (or (null (allocation-details result))
|
|
(member (strategy (allocation-details result))
|
|
'(:constant :accumulator)))
|
|
(setf *last-instruction* '(:useless))
|
|
(progn
|
|
(emit-sta :address (data-reference result))
|
|
(setf *last-instruction* (list :store result)))))
|
|
|
|
(defun emit-load-data (data)
|
|
(if (or (member (strategy (allocation-details data))
|
|
'(:accumulator :direct-to-argvec))
|
|
(equal *last-instruction* (list :store data))
|
|
(equal *last-instruction* (list :load data)))
|
|
(setf *last-instruction* '(:useless))
|
|
(progn
|
|
(if (eql (strategy (allocation-details data)) :constant)
|
|
(emit-lda :immediate (ir-constant-value data))
|
|
(emit-lda :address (data-reference data)))
|
|
(setf *last-instruction* (list :load data)))))
|
|
|
|
(defmethod compile-ir ((inst ir-inst))
|
|
(warn "Skipped compiling ~A; no COMPILE-IR method" inst))
|
|
|
|
(defmethod compile-ir ((inst ir-plus))
|
|
(unless (= (length (inputs inst)) 2)
|
|
(error "During the final code generation step, IR-PLUS must have exactly 2 operands."))
|
|
(emit-load-data (first (inputs inst)))
|
|
(emit-asm-instruction :opcode #x18 :byte-length 1) ; Clear Carry
|
|
(if (eql (strategy (allocation-details (second (inputs inst))))
|
|
:constant)
|
|
(emit-adc :immediate (ir-constant-value (second (inputs inst))))
|
|
(emit-adc :address (data-reference (second (inputs inst)))))
|
|
(emit-store-result (output inst)))
|
|
|
|
(defmethod compile-ir ((inst ir-assign))
|
|
(emit-load-data (input inst))
|
|
(emit-store-result (output inst)))
|
|
|
|
(defmethod compile-ir ((inst ir-fetchvar))
|
|
(emit-load-data (input inst))
|
|
(emit-store-result (output inst)))
|
|
|
|
(defmethod compile-ir ((inst ir-call))
|
|
(loop :for arg :in (inputs inst)
|
|
:for arg-index :from 0
|
|
:do (emit-load-data arg)
|
|
:unless (eql (strategy (allocation-details arg)) :direct-to-argvec)
|
|
:do (emit-sta :address (+ arg-index +argvec-offset+)))
|
|
(emit-asm-instruction :opcode #x20 :operand (callee inst) :byte-length 1)
|
|
(emit-store-result (output inst)))
|
|
|
|
(defun link-compute-addresses (start-instruction origin-address)
|
|
"First linking pass, computes the addresses of all labels."
|
|
(let ((address origin-address))
|
|
(loop :for asm-obj := start-instruction :then (next asm-obj)
|
|
:until (null asm-obj)
|
|
:do (cond ((typep asm-obj 'asm-label)
|
|
(setf (address asm-obj) address))
|
|
((typep asm-obj 'asm-instruction)
|
|
(incf address (byte-length asm-obj)))))
|
|
(values start-instruction address)))
|
|
|
|
(defun link-assembly (start-instruction origin-address)
|
|
(link-compute-addresses start-instruction origin-address)
|
|
;; TODO: Second pass, replacing labels with their addresses, both for
|
|
;; constant labels such as assembly routines and for generated labels.
|
|
;;(values start-instruction address)
|
|
)
|
|
|
|
(defun quick-and-dirty-test-compile (text &key print-ir-p print-alloc-p make-asm-p)
|
|
(with-input-from-string (source-stream text)
|
|
(let ((*token-stream* (make-token-stream (tokenize source-stream))))
|
|
(let ((rb (with-compilation-setup (root-block builder)
|
|
(compile-node (match-syntax program) builder)
|
|
root-block)))
|
|
(do-iblocks (ib rb)
|
|
(optim-reorder-arguments ib)
|
|
(optim-direct-variable-use ib)
|
|
(optim-call-duplicate-args ib)
|
|
(optim-remove-unused ib))
|
|
(let ((allocations (allocate-values rb)))
|
|
(optim-reuse-temporary-slots rb allocations)
|
|
(when print-ir-p
|
|
(print-iblocks rb)
|
|
(terpri))
|
|
(when print-alloc-p
|
|
(loop :for allocation :in allocations
|
|
:do (format t "~%~A - ~A~{ - ~A~}"
|
|
(data allocation)
|
|
(strategy allocation)
|
|
(unless (null (varvec-index allocation))
|
|
(list (varvec-index allocation)))))
|
|
(terpri))
|
|
(when make-asm-p
|
|
(with-variable-allocations allocations
|
|
(let ((*asm-head* nil)
|
|
(*asm-foot* nil))
|
|
(do-iblocks (ib rb)
|
|
(emit-asm-label ib)
|
|
(do-instructions (inst ib)
|
|
(compile-ir inst)))
|
|
(link-assembly *asm-head* #x8000)))))))))
|