diff --git a/wip-duuqnd/user-side-compiler/backend/code-generator.lisp b/wip-duuqnd/user-side-compiler/backend/code-generator.lisp new file mode 100644 index 0000000..10b8833 --- /dev/null +++ b/wip-duuqnd/user-side-compiler/backend/code-generator.lisp @@ -0,0 +1,177 @@ +(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)))))))))