177 lines
6.9 KiB
Common Lisp
177 lines
6.9 KiB
Common Lisp
(in-package #:user-side-compiler)
|
|
|
|
(defclass asm-object ()
|
|
((%source :accessor source :initarg :source :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-output* '())
|
|
|
|
(defun emit-asm-object (obj)
|
|
(check-type obj asm-object)
|
|
(setf *asm-output* (append *asm-output* (list obj))))
|
|
|
|
(defun emit-asm-instruction (&rest initargs)
|
|
(emit-asm-object (apply #'make-instance
|
|
'asm-instruction
|
|
initargs)))
|
|
|
|
(defun emit-asm-label (identity)
|
|
(emit-asm-object (make-instance 'asm-label :name identity)))
|
|
|
|
(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-assembly (assembly-list origin-address)
|
|
(let ((address origin-address))
|
|
(loop :for asm-obj :in assembly-list
|
|
:do (cond ((typep asm-obj 'asm-label)
|
|
(setf (address asm-obj) address))
|
|
((typep asm-obj 'asm-instruction)
|
|
(incf address (byte-length asm-obj)))))
|
|
;; TODO: Second pass, replacing labels with their addresses, both for
|
|
;; constant labels such as assembly routines and for generated labels.
|
|
(values assembly-list 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-output* '()))
|
|
(do-iblocks (ib rb)
|
|
(emit-asm-label ib)
|
|
(do-instructions (inst ib)
|
|
(compile-ir inst)))
|
|
(link-assembly *asm-output* #x8000)))))))))
|